-- | You don't normally need to use this Lex module directly - it is
--   called automatically by the parser.  (This interface is only exposed
--   for debugging purposes.)
--
-- This is a hand-written lexer for tokenising the text of an XML
-- document so that it is ready for parsing.  It attaches position
-- information in (line,column) format to every token.  The main
-- entry point is 'xmlLex'.  A secondary entry point, 'xmlReLex', is
-- provided for when the parser needs to stuff a string back onto
-- the front of the text and re-tokenise it (typically when expanding
-- macros).
--
-- As one would expect, the lexer is essentially a small finite
-- state machine.

module Text.XML.HaXml.Lex
  (
  -- * Entry points to the lexer
    xmlLex         -- :: String -> String -> [Token]
  , xmlReLex       -- :: Posn   -> String -> [Token]
  , reLexEntityValue -- :: (String->Maybe String) -> Posn -> String -> [Token]
  -- * Token types
  , Token
  , TokenT(..)
  , Special(..)
  , Section(..)
  ) where

import Data.Char
import Text.XML.HaXml.Posn

data Where = InTag String | NotInTag
    deriving (Where -> Where -> Bool
(Where -> Where -> Bool) -> (Where -> Where -> Bool) -> Eq Where
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Where -> Where -> Bool
$c/= :: Where -> Where -> Bool
== :: Where -> Where -> Bool
$c== :: Where -> Where -> Bool
Eq)

-- | All tokens are paired up with a source position.
--   Lexical errors are passed back as a special @TokenT@ value.
type Token = (Posn, TokenT)

-- | The basic token type.
data TokenT =
      TokCommentOpen            -- ^   \<!--
    | TokCommentClose           -- ^   -->
    | TokPIOpen                 -- ^   \<?
    | TokPIClose                -- ^   ?>
    | TokSectionOpen            -- ^   \<![
    | TokSectionClose           -- ^   ]]>
    | TokSection Section        -- ^   CDATA INCLUDE IGNORE etc
    | TokSpecialOpen            -- ^   \<!
    | TokSpecial Special        -- ^   DOCTYPE ELEMENT ATTLIST etc
    | TokEndOpen                -- ^   \<\/
    | TokEndClose               -- ^   \/>
    | TokAnyOpen                -- ^   \<
    | TokAnyClose               -- ^   >
    | TokSqOpen                 -- ^   \[
    | TokSqClose                -- ^   \]
    | TokEqual                  -- ^   =
    | TokQuery                  -- ^   ?
    | TokStar                   -- ^   \*
    | TokPlus                   -- ^   +
    | TokAmp                    -- ^   &
    | TokSemi                   -- ^   ;
    | TokHash                   -- ^   #
    | TokBraOpen                -- ^   (
    | TokBraClose               -- ^   )
    | TokPipe                   -- ^   |
    | TokPercent                -- ^   %
    | TokComma                  -- ^   ,
    | TokQuote                  -- ^   \'\' or \"\"
    | TokName      String       -- ^   begins with letter, no spaces
    | TokFreeText  String       -- ^   any character data
    | TokNull                   -- ^   fake token
    | TokError     String       -- ^   lexical error
    deriving (TokenT -> TokenT -> Bool
(TokenT -> TokenT -> Bool)
-> (TokenT -> TokenT -> Bool) -> Eq TokenT
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TokenT -> TokenT -> Bool
$c/= :: TokenT -> TokenT -> Bool
== :: TokenT -> TokenT -> Bool
$c== :: TokenT -> TokenT -> Bool
Eq)

data Special =
      DOCTYPEx
    | ELEMENTx
    | ATTLISTx
    | ENTITYx
    | NOTATIONx
    deriving (Special -> Special -> Bool
(Special -> Special -> Bool)
-> (Special -> Special -> Bool) -> Eq Special
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Special -> Special -> Bool
$c/= :: Special -> Special -> Bool
== :: Special -> Special -> Bool
$c== :: Special -> Special -> Bool
Eq,Int -> Special -> ShowS
[Special] -> ShowS
Special -> String
(Int -> Special -> ShowS)
-> (Special -> String) -> ([Special] -> ShowS) -> Show Special
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Special] -> ShowS
$cshowList :: [Special] -> ShowS
show :: Special -> String
$cshow :: Special -> String
showsPrec :: Int -> Special -> ShowS
$cshowsPrec :: Int -> Special -> ShowS
Show)
data Section =
      CDATAx
    | INCLUDEx
    | IGNOREx
    deriving (Section -> Section -> Bool
(Section -> Section -> Bool)
-> (Section -> Section -> Bool) -> Eq Section
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Section -> Section -> Bool
$c/= :: Section -> Section -> Bool
== :: Section -> Section -> Bool
$c== :: Section -> Section -> Bool
Eq,Int -> Section -> ShowS
[Section] -> ShowS
Section -> String
(Int -> Section -> ShowS)
-> (Section -> String) -> ([Section] -> ShowS) -> Show Section
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Section] -> ShowS
$cshowList :: [Section] -> ShowS
show :: Section -> String
$cshow :: Section -> String
showsPrec :: Int -> Section -> ShowS
$cshowsPrec :: Int -> Section -> ShowS
Show)

instance Show TokenT where
  showsPrec :: Int -> TokenT -> ShowS
showsPrec Int
_p TokenT
TokCommentOpen           = String -> ShowS
showString     String
"<!--"
  showsPrec Int
_p TokenT
TokCommentClose          = String -> ShowS
showString     String
"-->"
  showsPrec Int
_p TokenT
TokPIOpen                = String -> ShowS
showString     String
"<?"
  showsPrec Int
_p TokenT
TokPIClose               = String -> ShowS
showString     String
"?>"
  showsPrec Int
_p TokenT
TokSectionOpen           = String -> ShowS
showString     String
"<!["
  showsPrec Int
_p TokenT
TokSectionClose          = String -> ShowS
showString     String
"]]>"
  showsPrec  Int
p (TokSection Section
s)           = Int -> Section -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p Section
s
  showsPrec Int
_p TokenT
TokSpecialOpen           = String -> ShowS
showString     String
"<!"
  showsPrec  Int
p (TokSpecial Special
s)           = Int -> Special -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p Special
s
  showsPrec Int
_p TokenT
TokEndOpen               = String -> ShowS
showString     String
"</"
  showsPrec Int
_p TokenT
TokEndClose              = String -> ShowS
showString     String
"/>"
  showsPrec Int
_p TokenT
TokAnyOpen               = String -> ShowS
showString     String
"<"
  showsPrec Int
_p TokenT
TokAnyClose              = String -> ShowS
showString     String
">"
  showsPrec Int
_p TokenT
TokSqOpen                = String -> ShowS
showString     String
"["
  showsPrec Int
_p TokenT
TokSqClose               = String -> ShowS
showString     String
"]"
  showsPrec Int
_p TokenT
TokEqual                 = String -> ShowS
showString     String
"="
  showsPrec Int
_p TokenT
TokQuery                 = String -> ShowS
showString     String
"?"
  showsPrec Int
_p TokenT
TokStar                  = String -> ShowS
showString     String
"*"
  showsPrec Int
_p TokenT
TokPlus                  = String -> ShowS
showString     String
"+"
  showsPrec Int
_p TokenT
TokAmp                   = String -> ShowS
showString     String
"&"
  showsPrec Int
_p TokenT
TokSemi                  = String -> ShowS
showString     String
";"
  showsPrec Int
_p TokenT
TokHash                  = String -> ShowS
showString     String
"#"
  showsPrec Int
_p TokenT
TokBraOpen               = String -> ShowS
showString     String
"("
  showsPrec Int
_p TokenT
TokBraClose              = String -> ShowS
showString     String
")"
  showsPrec Int
_p TokenT
TokPipe                  = String -> ShowS
showString     String
"|"
  showsPrec Int
_p TokenT
TokPercent               = String -> ShowS
showString     String
"%"
  showsPrec Int
_p TokenT
TokComma                 = String -> ShowS
showString     String
","
  showsPrec Int
_p TokenT
TokQuote                 = String -> ShowS
showString     String
"' or \""
  showsPrec Int
_p (TokName      String
s)         = String -> ShowS
showString     String
s
  showsPrec Int
_p (TokFreeText  String
s)         = String -> ShowS
showString     String
s
  showsPrec Int
_p TokenT
TokNull                  = String -> ShowS
showString     String
"(null)"
  showsPrec Int
_p (TokError     String
s)         = String -> ShowS
showString     String
s

--trim, revtrim :: String -> String
--trim    = f . f         where f = reverse . dropWhile isSpace
--revtrim = f.reverse.f   where f = dropWhile isSpace
--revtrim = reverse . dropWhile (=='\n')  -- most recently used defn.

emit :: TokenT -> Posn -> Token
emit :: TokenT -> Posn -> Token
emit TokenT
tok Posn
p = Posn -> Int
forcep Posn
p Int -> Token -> Token
`seq` (Posn
p,TokenT
tok)

lexerror :: String -> Posn -> [Token]
lexerror :: String -> Posn -> [Token]
lexerror String
s Posn
p = [(Posn
p, String -> TokenT
TokError (String
"Lexical error:\n  "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
s))]

skip :: Int -> Posn -> String -> (Posn->String->[Token]) -> [Token]
skip :: Int -> Posn -> String -> (Posn -> String -> [Token]) -> [Token]
skip Int
n Posn
p String
s Posn -> String -> [Token]
k = Posn -> String -> [Token]
k (Int -> Posn -> Posn
addcol Int
n Posn
p) (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
n String
s)

blank :: ([Where]->Posn->String->[Token]) -> [Where]-> Posn-> String-> [Token]
blank :: ([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
_  (InTag String
t:[Where]
_) Posn
p [] = String -> Posn -> [Token]
lexerror (String
"unexpected EOF within "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
t) Posn
p
blank [Where] -> Posn -> String -> [Token]
_          [Where]
_   Posn
_ [] = []
blank [Where] -> Posn -> String -> [Token]
k      [Where]
w Posn
p (Char
' ': String
s) = ([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
k [Where]
w (Int -> Posn -> Posn
addcol Int
1 Posn
p) String
s
blank [Where] -> Posn -> String -> [Token]
k      [Where]
w Posn
p (Char
'\t':String
s) = ([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
k [Where]
w (Posn -> Posn
tab Posn
p) String
s
blank [Where] -> Posn -> String -> [Token]
k      [Where]
w Posn
p (Char
'\n':String
s) = ([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
k [Where]
w (Posn -> Posn
newline Posn
p) String
s
blank [Where] -> Posn -> String -> [Token]
k      [Where]
w Posn
p (Char
'\r':String
s) = ([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
k [Where]
w  Posn
p String
s
blank [Where] -> Posn -> String -> [Token]
k   [Where]
w Posn
p (Char
'\xa0': String
s) = ([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
k [Where]
w (Int -> Posn -> Posn
addcol Int
1 Posn
p) String
s
blank [Where] -> Posn -> String -> [Token]
k      [Where]
w Posn
p    String
s     = [Where] -> Posn -> String -> [Token]
k [Where]
w Posn
p String
s

prefixes :: String -> String -> Bool
[]     prefixes :: String -> String -> Bool
`prefixes`   String
_    = Bool
True
(Char
x:String
xs) `prefixes` (Char
y:String
ys) = Char
xChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
y Bool -> Bool -> Bool
&& String
xs String -> String -> Bool
`prefixes` String
ys
(Char
_:String
_)  `prefixes`   []   = Bool
False --error "unexpected EOF in prefix"

textUntil, textOrRefUntil
    :: [Char] -> TokenT -> [Char] -> Posn -> Posn -> [Char]
       -> (Posn->String->[Token]) -> [Token]

textUntil :: String
-> TokenT
-> String
-> Posn
-> Posn
-> String
-> (Posn -> String -> [Token])
-> [Token]
textUntil String
close TokenT
_tok String
_acc Posn
pos Posn
p [] Posn -> String -> [Token]
_k =
    String -> Posn -> [Token]
lexerror (String
"unexpected EOF while looking for closing token "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
close
              String -> ShowS
forall a. [a] -> [a] -> [a]
++String
"\n  to match the opening token in "String -> ShowS
forall a. [a] -> [a] -> [a]
++Posn -> String
forall a. Show a => a -> String
show Posn
pos) Posn
p
textUntil String
close  TokenT
tok  String
acc Posn
pos Posn
p (Char
s:String
ss) Posn -> String -> [Token]
k
    | String
close String -> String -> Bool
`prefixes` (Char
sChar -> ShowS
forall a. a -> [a] -> [a]
:String
ss)  = TokenT -> Posn -> Token
emit (String -> TokenT
TokFreeText (ShowS
forall a. [a] -> [a]
reverse String
acc)) Posn
posToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:
                                 TokenT -> Posn -> Token
emit TokenT
tok Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:
                                 Int -> Posn -> String -> (Posn -> String -> [Token]) -> [Token]
skip (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
closeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Int -> Posn -> Posn
addcol Int
1 Posn
p) String
ss Posn -> String -> [Token]
k
    | TokenT
tokTokenT -> TokenT -> Bool
forall a. Eq a => a -> a -> Bool
==TokenT
TokSemi Bool -> Bool -> Bool
&& String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
acc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
8 -- special case for repairing broken &
                               = TokenT -> Posn -> Token
emit (String -> TokenT
TokFreeText String
"amp") Posn
posToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:
                                 TokenT -> Posn -> Token
emit TokenT
tok Posn
posToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:
                                 Posn -> String -> [Token]
k (Int -> Posn -> Posn
addcol Int
1 Posn
pos) (ShowS
forall a. [a] -> [a]
reverse String
accString -> ShowS
forall a. [a] -> [a] -> [a]
++Char
sChar -> ShowS
forall a. a -> [a] -> [a]
:String
ss)
    | Char -> Bool
isSpace Char
s  = String
-> TokenT
-> String
-> Posn
-> Posn
-> String
-> (Posn -> String -> [Token])
-> [Token]
textUntil String
close TokenT
tok (Char
sChar -> ShowS
forall a. a -> [a] -> [a]
:String
acc) Posn
pos (Char -> Posn -> Posn
white Char
s Posn
p) String
ss Posn -> String -> [Token]
k
    | Bool
otherwise  = String
-> TokenT
-> String
-> Posn
-> Posn
-> String
-> (Posn -> String -> [Token])
-> [Token]
textUntil String
close TokenT
tok (Char
sChar -> ShowS
forall a. a -> [a] -> [a]
:String
acc) Posn
pos (Int -> Posn -> Posn
addcol Int
1 Posn
p) String
ss Posn -> String -> [Token]
k

textOrRefUntil :: String
-> TokenT
-> String
-> Posn
-> Posn
-> String
-> (Posn -> String -> [Token])
-> [Token]
textOrRefUntil String
close TokenT
_tok String
_acc Posn
pos Posn
p [] Posn -> String -> [Token]
_k =
    String -> Posn -> [Token]
lexerror (String
"unexpected EOF while looking for closing token "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
close
              String -> ShowS
forall a. [a] -> [a] -> [a]
++String
"\n  to match the opening token in "String -> ShowS
forall a. [a] -> [a] -> [a]
++Posn -> String
forall a. Show a => a -> String
show Posn
pos) Posn
p
textOrRefUntil String
close  TokenT
tok  String
acc Posn
pos Posn
p (Char
s:String
ss) Posn -> String -> [Token]
k
    | String
close String -> String -> Bool
`prefixes` (Char
sChar -> ShowS
forall a. a -> [a] -> [a]
:String
ss)  = TokenT -> Posn -> Token
emit (String -> TokenT
TokFreeText (ShowS
forall a. [a] -> [a]
reverse String
acc)) Posn
posToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:
                                 TokenT -> Posn -> Token
emit TokenT
tok Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:
                                 Int -> Posn -> String -> (Posn -> String -> [Token]) -> [Token]
skip (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
closeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Int -> Posn -> Posn
addcol Int
1 Posn
p) String
ss Posn -> String -> [Token]
k
    | Char
sChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'&'     = (if Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
acc)
                       then (TokenT -> Posn -> Token
emit (String -> TokenT
TokFreeText (ShowS
forall a. [a] -> [a]
reverse String
acc)) Posn
posToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:)
                       else [Token] -> [Token]
forall a. a -> a
id)
                   (TokenT -> Posn -> Token
emit TokenT
TokAmp Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:
                    String
-> TokenT
-> String
-> Posn
-> Posn
-> String
-> (Posn -> String -> [Token])
-> [Token]
textUntil String
";" TokenT
TokSemi String
"" Posn
p (Int -> Posn -> Posn
addcol Int
1 Posn
p) String
ss
                        (\Posn
p' String
i-> String
-> TokenT
-> String
-> Posn
-> Posn
-> String
-> (Posn -> String -> [Token])
-> [Token]
textOrRefUntil String
close TokenT
tok String
"" Posn
p Posn
p' String
i Posn -> String -> [Token]
k))
    | Char -> Bool
isSpace Char
s  = String
-> TokenT
-> String
-> Posn
-> Posn
-> String
-> (Posn -> String -> [Token])
-> [Token]
textOrRefUntil String
close TokenT
tok (Char
sChar -> ShowS
forall a. a -> [a] -> [a]
:String
acc) Posn
pos (Char -> Posn -> Posn
white Char
s Posn
p) String
ss Posn -> String -> [Token]
k
    | Bool
otherwise  = String
-> TokenT
-> String
-> Posn
-> Posn
-> String
-> (Posn -> String -> [Token])
-> [Token]
textOrRefUntil String
close TokenT
tok (Char
sChar -> ShowS
forall a. a -> [a] -> [a]
:String
acc) Posn
pos (Int -> Posn -> Posn
addcol Int
1 Posn
p) String
ss Posn -> String -> [Token]
k

----

-- | The first argument to 'xmlLex' is the filename (used for source positions,
--   especially in error messages), and the second is the string content of
--   the XML file.
xmlLex :: String -> String -> [Token]
xmlLex :: String -> String -> [Token]
xmlLex String
filename = [Where] -> Posn -> String -> [Token]
xmlAny [] (String -> Maybe Posn -> Posn
posInNewCxt String
filename Maybe Posn
forall a. Maybe a
Nothing)

-- | 'xmlReLex' is used when the parser expands a macro (PE reference).
--    The expansion of the macro must be re-lexed as if for the first time.
xmlReLex :: Posn -> String -> [Token]
xmlReLex :: Posn -> String -> [Token]
xmlReLex Posn
p String
s
      | String
"INCLUDE"  String -> String -> Bool
`prefixes` String
s  = TokenT -> Posn -> Token
emit (Section -> TokenT
TokSection Section
INCLUDEx) Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Int -> [Token]
k Int
7
      | String
"IGNORE"   String -> String -> Bool
`prefixes` String
s  = TokenT -> Posn -> Token
emit (Section -> TokenT
TokSection Section
IGNOREx) Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:  Int -> [Token]
k Int
6
      | Bool
otherwise = ([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
xmlAny [] Posn
p String
s
  where
    k :: Int -> [Token]
k Int
n = Int -> Posn -> String -> (Posn -> String -> [Token]) -> [Token]
skip Int
n Posn
p String
s (([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
xmlAny [])

-- | 'reLexEntityValue' is used solely within parsing an entityvalue.
--   Normally, a PERef is logically separated from its surroundings by
--   whitespace.  But in an entityvalue, a PERef can be juxtaposed to
--   an identifier, so the expansion forms a new identifier.
--   Thus the need to rescan the whole text for possible PERefs.
reLexEntityValue :: (String->Maybe String) -> Posn -> String -> [Token]
reLexEntityValue :: (String -> Maybe String) -> Posn -> String -> [Token]
reLexEntityValue String -> Maybe String
lookup Posn
p String
s =
    String
-> TokenT
-> String
-> Posn
-> Posn
-> String
-> (Posn -> String -> [Token])
-> [Token]
textOrRefUntil String
"%" TokenT
TokNull [] Posn
p Posn
p (ShowS
expand String
sString -> ShowS
forall a. [a] -> [a] -> [a]
++String
"%") ([Where] -> Posn -> String -> [Token]
xmlAny [])
  where
    expand :: ShowS
expand []       = []
    expand (Char
'%':String
xs) = let (String
sym,String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
';') String
xs in
                      case String -> Maybe String
lookup String
sym of
                        Just String
val -> ShowS
expand String
val String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
expand (ShowS
forall a. [a] -> [a]
tail String
rest)
                        Maybe String
Nothing  -> String
"%"String -> ShowS
forall a. [a] -> [a] -> [a]
++String
symString -> ShowS
forall a. [a] -> [a] -> [a]
++String
";"String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
expand (ShowS
forall a. [a] -> [a]
tail String
rest) -- hmmm
    expand (Char
x:String
xs)   = Char
xChar -> ShowS
forall a. a -> [a] -> [a]
: ShowS
expand String
xs

--xmltop :: Posn -> String -> [Token]
--xmltop p [] = []
--xmltop p s
--    | "<?"   `prefixes` s = emit TokPIOpen p:      next 2 (xmlPI [InTag "<?...?>"])
--    | "<!--" `prefixes` s = emit TokCommentOpen p: next 4 (xmlComment [])
--    | "<!"   `prefixes` s = emit TokSpecialOpen p: next 2 (xmlSpecial [InTag "<!...>"])
--    | otherwise           = lexerror "expected <?xml?> or <!DOCTYPE>" p
--  where next n k = skip n p s k

xmlPI, xmlPIEnd, xmlComment, xmlAny, xmlTag, xmlSection, xmlSpecial
    :: [Where] -> Posn -> String -> [Token]

xmlPI :: [Where] -> Posn -> String -> [Token]
xmlPI      [Where]
w Posn
p String
s = Posn -> String -> String -> (Posn -> String -> [Token]) -> [Token]
xmlName Posn
p String
s String
"name of processor in <? ?>" (([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
xmlPIEnd [Where]
w)
xmlPIEnd :: [Where] -> Posn -> String -> [Token]
xmlPIEnd   [Where]
w Posn
p String
s = String
-> TokenT
-> String
-> Posn
-> Posn
-> String
-> (Posn -> String -> [Token])
-> [Token]
textUntil String
"?>"  TokenT
TokPIClose String
"" Posn
p Posn
p String
s (([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
xmlAny ([Where] -> [Where]
forall a. [a] -> [a]
tail [Where]
w))
xmlComment :: [Where] -> Posn -> String -> [Token]
xmlComment [Where]
w Posn
p String
s = String
-> TokenT
-> String
-> Posn
-> Posn
-> String
-> (Posn -> String -> [Token])
-> [Token]
textUntil String
"-->" TokenT
TokCommentClose String
"" Posn
p Posn
p String
s (([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
xmlAny [Where]
w)

-- Note: the order of the clauses in xmlAny is very important.
-- Some matches must precede the NotInTag test, the rest must follow it.
xmlAny :: [Where] -> Posn -> String -> [Token]
xmlAny  (InTag String
t:[Where]
_)  Posn
p [] = String -> Posn -> [Token]
lexerror (String
"unexpected EOF within "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
t) Posn
p
xmlAny          [Where]
_    Posn
_ [] = []
xmlAny [Where]
w Posn
p s :: String
s@(Char
'<':String
ss)
    | String
"?"   String -> String -> Bool
`prefixes` String
ss = TokenT -> Posn -> Token
emit TokenT
TokPIOpen Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:
                                         Int -> Posn -> String -> (Posn -> String -> [Token]) -> [Token]
skip Int
2 Posn
p String
s ([Where] -> Posn -> String -> [Token]
xmlPI (String -> Where
InTag String
"<?...?>"Where -> [Where] -> [Where]
forall a. a -> [a] -> [a]
:[Where]
w))
    | String
"!--" String -> String -> Bool
`prefixes` String
ss = TokenT -> Posn -> Token
emit TokenT
TokCommentOpen Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Int -> Posn -> String -> (Posn -> String -> [Token]) -> [Token]
skip Int
4 Posn
p String
s ([Where] -> Posn -> String -> [Token]
xmlComment [Where]
w)
    | String
"!["  String -> String -> Bool
`prefixes` String
ss = TokenT -> Posn -> Token
emit TokenT
TokSectionOpen Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Int -> Posn -> String -> (Posn -> String -> [Token]) -> [Token]
skip Int
3 Posn
p String
s ([Where] -> Posn -> String -> [Token]
xmlSection [Where]
w)
    | String
"!"   String -> String -> Bool
`prefixes` String
ss = TokenT -> Posn -> Token
emit TokenT
TokSpecialOpen Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:
                                     Int -> Posn -> String -> (Posn -> String -> [Token]) -> [Token]
skip Int
2 Posn
p String
s ([Where] -> Posn -> String -> [Token]
xmlSpecial (String -> Where
InTag String
"<!...>"Where -> [Where] -> [Where]
forall a. a -> [a] -> [a]
:[Where]
w))
    | String
"/"   String -> String -> Bool
`prefixes` String
ss = TokenT -> Posn -> Token
emit TokenT
TokEndOpen Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:
                                    Int -> Posn -> String -> (Posn -> String -> [Token]) -> [Token]
skip Int
2 Posn
p String
s ([Where] -> Posn -> String -> [Token]
xmlTag (String -> Where
InTag String
"</...>"Where -> [Where] -> [Where]
forall a. a -> [a] -> [a]
:[Where] -> [Where]
tale [Where]
w))
    | Bool
otherwise           = TokenT -> Posn -> Token
emit TokenT
TokAnyOpen Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:
                                 Int -> Posn -> String -> (Posn -> String -> [Token]) -> [Token]
skip Int
1 Posn
p String
s ([Where] -> Posn -> String -> [Token]
xmlTag (String -> Where
InTag String
"<...>"Where -> [Where] -> [Where]
forall a. a -> [a] -> [a]
:Where
NotInTagWhere -> [Where] -> [Where]
forall a. a -> [a] -> [a]
:[Where]
w))
    where tale :: [Where] -> [Where]
tale [] = [Where
NotInTag] -- cope with non-well-formed input
          tale [Where]
xs = [Where] -> [Where]
forall a. [a] -> [a]
tail [Where]
xs
xmlAny (Where
_:Where
_:[Where]
w) Posn
p s :: String
s@(Char
'/':String
ss)
    | String
">"   String -> String -> Bool
`prefixes` String
ss = TokenT -> Posn -> Token
emit TokenT
TokEndClose Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Int -> Posn -> String -> (Posn -> String -> [Token]) -> [Token]
skip Int
2 Posn
p String
s ([Where] -> Posn -> String -> [Token]
xmlAny [Where]
w)
xmlAny [Where]
w Posn
p (Char
'&':String
ss) = TokenT -> Posn -> Token
emit TokenT
TokAmp Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:      String
-> TokenT
-> String
-> Posn
-> Posn
-> String
-> (Posn -> String -> [Token])
-> [Token]
textUntil String
";" TokenT
TokSemi String
"" Posn
p
                                                     (Int -> Posn -> Posn
addcol Int
1 Posn
p) String
ss ([Where] -> Posn -> String -> [Token]
xmlAny [Where]
w)
xmlAny w :: [Where]
w@(Where
NotInTag:[Where]
_) Posn
p String
s = String -> [Where] -> Posn -> Posn -> String -> [Token]
xmlContent String
"" [Where]
w Posn
p Posn
p String
s
-- everything below here is implicitly InTag.
xmlAny [Where]
w Posn
p (Char
'>':String
ss) = TokenT -> Posn -> Token
emit TokenT
TokAnyClose Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Where] -> Posn -> String -> [Token]
xmlAny ([Where] -> [Where]
forall a. [a] -> [a]
tail [Where]
w) (Int -> Posn -> Posn
addcol Int
1 Posn
p) String
ss
xmlAny [Where]
w Posn
p (Char
'[':String
ss) = TokenT -> Posn -> Token
emit TokenT
TokSqOpen Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:
                                 ([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
xmlAny (String -> Where
InTag String
"[...]"Where -> [Where] -> [Where]
forall a. a -> [a] -> [a]
:[Where]
w) (Int -> Posn -> Posn
addcol Int
1 Posn
p) String
ss
xmlAny [Where]
w Posn
p (Char
']':String
ss)
    | String
"]>" String -> String -> Bool
`prefixes` String
ss  =
                 TokenT -> Posn -> Token
emit TokenT
TokSectionClose Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:  Int -> Posn -> String -> (Posn -> String -> [Token]) -> [Token]
skip Int
3 Posn
p (Char
']'Char -> ShowS
forall a. a -> [a] -> [a]
:String
ss) ([Where] -> Posn -> String -> [Token]
xmlAny ([Where] -> [Where]
forall a. [a] -> [a]
tail [Where]
w))
    | Bool
otherwise  =    TokenT -> Posn -> Token
emit TokenT
TokSqClose Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:  ([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
xmlAny ([Where] -> [Where]
forall a. [a] -> [a]
tail [Where]
w) (Int -> Posn -> Posn
addcol Int
1 Posn
p) String
ss
xmlAny [Where]
w Posn
p (Char
'(':String
ss) = TokenT -> Posn -> Token
emit TokenT
TokBraOpen Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:
                                 ([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
xmlAny (String -> Where
InTag String
"(...)"Where -> [Where] -> [Where]
forall a. a -> [a] -> [a]
:[Where]
w) (Int -> Posn -> Posn
addcol Int
1 Posn
p) String
ss
xmlAny [Where]
w Posn
p (Char
')':String
ss) = TokenT -> Posn -> Token
emit TokenT
TokBraClose Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: ([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
xmlAny ([Where] -> [Where]
forall a. [a] -> [a]
tail [Where]
w) (Int -> Posn -> Posn
addcol Int
1 Posn
p) String
ss
xmlAny [Where]
w Posn
p (Char
'=':String
ss) = TokenT -> Posn -> Token
emit TokenT
TokEqual Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:    ([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
xmlAny [Where]
w (Int -> Posn -> Posn
addcol Int
1 Posn
p) String
ss
xmlAny [Where]
w Posn
p (Char
'*':String
ss) = TokenT -> Posn -> Token
emit TokenT
TokStar Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:     ([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
xmlAny [Where]
w (Int -> Posn -> Posn
addcol Int
1 Posn
p) String
ss
xmlAny [Where]
w Posn
p (Char
'+':String
ss) = TokenT -> Posn -> Token
emit TokenT
TokPlus Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:     ([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
xmlAny [Where]
w (Int -> Posn -> Posn
addcol Int
1 Posn
p) String
ss
xmlAny [Where]
w Posn
p (Char
'?':String
ss) = TokenT -> Posn -> Token
emit TokenT
TokQuery Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:    ([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
xmlAny [Where]
w (Int -> Posn -> Posn
addcol Int
1 Posn
p) String
ss
xmlAny [Where]
w Posn
p (Char
'|':String
ss) = TokenT -> Posn -> Token
emit TokenT
TokPipe Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:     ([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
xmlAny [Where]
w (Int -> Posn -> Posn
addcol Int
1 Posn
p) String
ss
xmlAny [Where]
w Posn
p (Char
'%':String
ss) = TokenT -> Posn -> Token
emit TokenT
TokPercent Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:  ([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
xmlAny [Where]
w (Int -> Posn -> Posn
addcol Int
1 Posn
p) String
ss
xmlAny [Where]
w Posn
p (Char
';':String
ss) = TokenT -> Posn -> Token
emit TokenT
TokSemi Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:     ([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
xmlAny [Where]
w (Int -> Posn -> Posn
addcol Int
1 Posn
p) String
ss
xmlAny [Where]
w Posn
p (Char
',':String
ss) = TokenT -> Posn -> Token
emit TokenT
TokComma Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:    ([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
xmlAny [Where]
w (Int -> Posn -> Posn
addcol Int
1 Posn
p) String
ss
xmlAny [Where]
w Posn
p (Char
'#':String
ss) = TokenT -> Posn -> Token
emit TokenT
TokHash Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:     ([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
xmlAny [Where]
w (Int -> Posn -> Posn
addcol Int
1 Posn
p) String
ss
xmlAny [Where]
w Posn
p (Char
'"':String
ss) = TokenT -> Posn -> Token
emit TokenT
TokQuote Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:    String
-> TokenT
-> String
-> Posn
-> Posn
-> String
-> (Posn -> String -> [Token])
-> [Token]
textOrRefUntil String
"\"" TokenT
TokQuote String
"" Posn
p1
                                                          Posn
p1 String
ss ([Where] -> Posn -> String -> [Token]
xmlAny [Where]
w)
                                             where p1 :: Posn
p1 = Int -> Posn -> Posn
addcol Int
1 Posn
p
xmlAny [Where]
w Posn
p (Char
'\'':String
ss) = TokenT -> Posn -> Token
emit TokenT
TokQuote Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:   String
-> TokenT
-> String
-> Posn
-> Posn
-> String
-> (Posn -> String -> [Token])
-> [Token]
textOrRefUntil String
"'" TokenT
TokQuote String
"" Posn
p1
                                                          Posn
p1 String
ss ([Where] -> Posn -> String -> [Token]
xmlAny [Where]
w)
                                             where p1 :: Posn
p1 = Int -> Posn -> Posn
addcol Int
1 Posn
p
xmlAny [Where]
w Posn
p String
s
    | Char -> Bool
isSpace (String -> Char
forall a. [a] -> a
head String
s)     = ([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
xmlAny [Where]
w Posn
p String
s
    | Char -> Bool
isAlphaNum (String -> Char
forall a. [a] -> a
head String
s) Bool -> Bool -> Bool
|| (String -> Char
forall a. [a] -> a
head String
s)Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`String
":_"
                           = Posn -> String -> String -> (Posn -> String -> [Token]) -> [Token]
xmlName Posn
p String
s String
"some kind of name" (([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
xmlAny [Where]
w)
    | Bool
otherwise            = String -> Posn -> [Token]
lexerror (String
"unrecognised token: "String -> ShowS
forall a. [a] -> [a] -> [a]
++Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
4 String
s) Posn
p

xmlTag :: [Where] -> Posn -> String -> [Token]
xmlTag [Where]
w Posn
p String
s = Posn -> String -> String -> (Posn -> String -> [Token]) -> [Token]
xmlName Posn
p String
s String
"tagname for element in < >" (([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
xmlAny [Where]
w)

xmlSection :: [Where] -> Posn -> String -> [Token]
xmlSection = ([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
xmlSection0
  where
    xmlSection0 :: [Where] -> Posn -> String -> [Token]
xmlSection0 [Where]
w Posn
p String
s
      | String
"CDATA["   String -> String -> Bool
`prefixes` String
s  = TokenT -> Posn -> Token
emit (Section -> TokenT
TokSection Section
CDATAx) Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:  [Where] -> Posn -> String -> Int -> [Token]
accum [Where]
w Posn
p String
s Int
6
      | String
"INCLUDE"  String -> String -> Bool
`prefixes` String
s  = TokenT -> Posn -> Token
emit (Section -> TokenT
TokSection Section
INCLUDEx) Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:    [Where] -> Posn -> String -> Int -> [Token]
k [Where]
w Posn
p String
s Int
7
      | String
"IGNORE"   String -> String -> Bool
`prefixes` String
s  = TokenT -> Posn -> Token
emit (Section -> TokenT
TokSection Section
IGNOREx) Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:     [Where] -> Posn -> String -> Int -> [Token]
k [Where]
w Posn
p String
s Int
6
      | String
"%"        String -> String -> Bool
`prefixes` String
s  = TokenT -> Posn -> Token
emit TokenT
TokPercent Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:               [Where] -> Posn -> String -> Int -> [Token]
k [Where]
w Posn
p String
s Int
1
      | Bool
otherwise = String -> Posn -> [Token]
lexerror (String
"expected CDATA, IGNORE, or INCLUDE, but got "
                             String -> ShowS
forall a. [a] -> [a] -> [a]
++Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
7 String
s) Posn
p
    accum :: [Where] -> Posn -> String -> Int -> [Token]
accum [Where]
w Posn
p String
s Int
n =
      let p0 :: Posn
p0 = Int -> Posn -> Posn
addcol Int
n Posn
p in
      String
-> TokenT
-> String
-> Posn
-> Posn
-> String
-> (Posn -> String -> [Token])
-> [Token]
textUntil String
"]]>" TokenT
TokSectionClose String
"" Posn
p0 Posn
p0 (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
n String
s) (([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
xmlAny [Where]
w)
    k :: [Where] -> Posn -> String -> Int -> [Token]
k [Where]
w Posn
p String
s Int
n =
      Int -> Posn -> String -> (Posn -> String -> [Token]) -> [Token]
skip Int
n Posn
p String
s ([Where] -> Posn -> String -> [Token]
xmlAny ({-InTag "<![section[ ... ]]>": -}[Where]
w))

xmlSpecial :: [Where] -> Posn -> String -> [Token]
xmlSpecial [Where]
w Posn
p String
s
    | String
"DOCTYPE"  String -> String -> Bool
`prefixes` String
s = TokenT -> Posn -> Token
emit (Special -> TokenT
TokSpecial Special
DOCTYPEx)  Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Int -> [Token]
k Int
7
    | String
"ELEMENT"  String -> String -> Bool
`prefixes` String
s = TokenT -> Posn -> Token
emit (Special -> TokenT
TokSpecial Special
ELEMENTx)  Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Int -> [Token]
k Int
7
    | String
"ATTLIST"  String -> String -> Bool
`prefixes` String
s = TokenT -> Posn -> Token
emit (Special -> TokenT
TokSpecial Special
ATTLISTx)  Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Int -> [Token]
k Int
7
    | String
"ENTITY"   String -> String -> Bool
`prefixes` String
s = TokenT -> Posn -> Token
emit (Special -> TokenT
TokSpecial Special
ENTITYx)   Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Int -> [Token]
k Int
6
    | String
"NOTATION" String -> String -> Bool
`prefixes` String
s = TokenT -> Posn -> Token
emit (Special -> TokenT
TokSpecial Special
NOTATIONx) Posn
pToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Int -> [Token]
k Int
8
    | Bool
otherwise = String -> Posn -> [Token]
lexerror
                    (String
"expected DOCTYPE, ELEMENT, ENTITY, ATTLIST, or NOTATION,"
                    String -> ShowS
forall a. [a] -> [a] -> [a]
++String
" but got "String -> ShowS
forall a. [a] -> [a] -> [a]
++Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
7 String
s) Posn
p
  where k :: Int -> [Token]
k Int
n = Int -> Posn -> String -> (Posn -> String -> [Token]) -> [Token]
skip Int
n Posn
p String
s (([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
xmlAny [Where]
w)

xmlName :: Posn -> [Char] -> [Char] -> (Posn->[Char]->[Token]) -> [Token]
xmlName :: Posn -> String -> String -> (Posn -> String -> [Token]) -> [Token]
xmlName Posn
p (Char
s:String
ss) String
cxt Posn -> String -> [Token]
k
    | Char -> Bool
isAlphaNum Char
s Bool -> Bool -> Bool
|| Char
sChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
':' Bool -> Bool -> Bool
|| Char
sChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'_'  = String
-> Posn -> Posn -> String -> (Posn -> String -> [Token]) -> [Token]
gatherName (Char
sChar -> ShowS
forall a. a -> [a] -> [a]
:[]) Posn
p (Int -> Posn -> Posn
addcol Int
1 Posn
p) String
ss Posn -> String -> [Token]
k
    | Bool
otherwise   = String -> Posn -> [Token]
lexerror (String
"expected a "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
cxtString -> ShowS
forall a. [a] -> [a] -> [a]
++String
", but got char "String -> ShowS
forall a. [a] -> [a] -> [a]
++Char -> String
forall a. Show a => a -> String
show Char
s) Posn
p
  where
    gatherName :: String
-> Posn -> Posn -> String -> (Posn -> String -> [Token]) -> [Token]
gatherName String
acc Posn
pos Posn
p [] Posn -> String -> [Token]
k =
        TokenT -> Posn -> Token
emit (String -> TokenT
TokName (ShowS
forall a. [a] -> [a]
reverse String
acc)) Posn
posToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Posn -> String -> [Token]
k Posn
p []
    --  lexerror ("unexpected EOF in name at "++show pos) p
    gatherName String
acc Posn
pos Posn
p (Char
s:String
ss) Posn -> String -> [Token]
k
        | Char -> Bool
isAlphaNum Char
s Bool -> Bool -> Bool
|| Char
s Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
".-_:"
                      = String
-> Posn -> Posn -> String -> (Posn -> String -> [Token]) -> [Token]
gatherName (Char
sChar -> ShowS
forall a. a -> [a] -> [a]
:String
acc) Posn
pos (Int -> Posn -> Posn
addcol Int
1 Posn
p) String
ss Posn -> String -> [Token]
k
        | Bool
otherwise   = TokenT -> Posn -> Token
emit (String -> TokenT
TokName (ShowS
forall a. [a] -> [a]
reverse String
acc)) Posn
posToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: Posn -> String -> [Token]
k Posn
p (Char
sChar -> ShowS
forall a. a -> [a] -> [a]
:String
ss)
xmlName Posn
p [] String
cxt Posn -> String -> [Token]
_ = String -> Posn -> [Token]
lexerror (String
"expected a "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
cxtString -> ShowS
forall a. [a] -> [a] -> [a]
++String
", but got end of input") Posn
p

xmlContent :: [Char] -> [Where] -> Posn -> Posn -> [Char] -> [Token]
xmlContent :: String -> [Where] -> Posn -> Posn -> String -> [Token]
xmlContent String
acc [Where]
_w Posn
_pos Posn
p [] = if (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
acc then []
                            else String -> Posn -> [Token]
lexerror String
"unexpected EOF between tags" Posn
p
xmlContent String
acc  [Where]
w  Posn
pos Posn
p (Char
s:String
ss)
    | Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
s String
"<&"    = {- if all isSpace acc then xmlAny w p (s:ss) else -}
                       TokenT -> Posn -> Token
emit (String -> TokenT
TokFreeText (ShowS
forall a. [a] -> [a]
reverse String
acc)) Posn
posToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Where] -> Posn -> String -> [Token]
xmlAny [Where]
w Posn
p (Char
sChar -> ShowS
forall a. a -> [a] -> [a]
:String
ss)
    | Char -> Bool
isSpace Char
s      = String -> [Where] -> Posn -> Posn -> String -> [Token]
xmlContent (Char
sChar -> ShowS
forall a. a -> [a] -> [a]
:String
acc) [Where]
w Posn
pos (Char -> Posn -> Posn
white Char
s Posn
p) String
ss
    | Bool
otherwise      = String -> [Where] -> Posn -> Posn -> String -> [Token]
xmlContent (Char
sChar -> ShowS
forall a. a -> [a] -> [a]
:String
acc) [Where]
w Posn
pos (Int -> Posn -> Posn
addcol Int
1 Posn
p) String
ss



--ident :: (String->TokenT) ->
--          Posn -> String -> [String] ->
--         (Posn->String->[String]->[Token]) -> [Token]
--ident tok p s ss k =
--    let (name,s0) = span (\c-> isAlphaNum c || c `elem` "`-_#.'/\\") s
--    in emit (tok name) p: skip (length name) p s ss k