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

lexerror :: String -> Posn -> [Token]
lexerror :: String -> Posn -> [Token]
lexerror s :: String
s p :: Posn
p = [(Posn
p, String -> TokenT
TokError ("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 n :: Int
n p :: Posn
p s :: String
s k :: 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 _  (InTag t :: String
t:_) p :: Posn
p [] = String -> Posn -> [Token]
lexerror ("unexpected EOF within "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
t) Posn
p
blank _          _   _ [] = []
blank k :: [Where] -> Posn -> String -> [Token]
k      w :: [Where]
w p :: Posn
p (' ': s :: String
s) = ([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
k [Where]
w (Int -> Posn -> Posn
addcol 1 Posn
p) String
s
blank k :: [Where] -> Posn -> String -> [Token]
k      w :: [Where]
w p :: Posn
p ('\t':s :: 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 k :: [Where] -> Posn -> String -> [Token]
k      w :: [Where]
w p :: Posn
p ('\n':s :: 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 k :: [Where] -> Posn -> String -> [Token]
k      w :: [Where]
w p :: Posn
p ('\r':s :: String
s) = ([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
k [Where]
w  Posn
p String
s
blank k :: [Where] -> Posn -> String -> [Token]
k   w :: [Where]
w p :: Posn
p ('\xa0': s :: String
s) = ([Where] -> Posn -> String -> [Token])
-> [Where] -> Posn -> String -> [Token]
blank [Where] -> Posn -> String -> [Token]
k [Where]
w (Int -> Posn -> Posn
addcol 1 Posn
p) String
s
blank k :: [Where] -> Posn -> String -> [Token]
k      w :: [Where]
w p :: Posn
p    s :: String
s     = [Where] -> Posn -> String -> [Token]
k [Where]
w Posn
p String
s

prefixes :: String -> String -> Bool
[]     prefixes :: String -> String -> Bool
`prefixes`   _    = Bool
True
(x :: Char
x:xs :: String
xs) `prefixes` (y :: Char
y:ys :: 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
(_:_)  `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 close :: String
close _tok :: TokenT
_tok _acc :: String
_acc pos :: Posn
pos p :: Posn
p [] _k :: Posn -> String -> [Token]
_k =
    String -> Posn -> [Token]
lexerror ("unexpected EOF while looking for closing token "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
close
              String -> ShowS
forall a. [a] -> [a] -> [a]
++"\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 close :: String
close  tok :: TokenT
tok  acc :: String
acc pos :: Posn
pos p :: Posn
p (s :: Char
s:ss :: String
ss) k :: 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
-1) (Int -> Posn -> Posn
addcol 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
>= 8 -- special case for repairing broken &
                               = TokenT -> Posn -> Token
emit (String -> TokenT
TokFreeText "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 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 1 Posn
p) String
ss Posn -> String -> [Token]
k

textOrRefUntil :: String
-> TokenT
-> String
-> Posn
-> Posn
-> String
-> (Posn -> String -> [Token])
-> [Token]
textOrRefUntil close :: String
close _tok :: TokenT
_tok _acc :: String
_acc pos :: Posn
pos p :: Posn
p [] _k :: Posn -> String -> [Token]
_k =
    String -> Posn -> [Token]
lexerror ("unexpected EOF while looking for closing token "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
close
              String -> ShowS
forall a. [a] -> [a] -> [a]
++"\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 close :: String
close  tok :: TokenT
tok  acc :: String
acc pos :: Posn
pos p :: Posn
p (s :: Char
s:ss :: String
ss) k :: 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
-1) (Int -> Posn -> Posn
addcol 1 Posn
p) String
ss Posn -> String -> [Token]
k
    | Char
sChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='&'     = (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 ";" TokenT
TokSemi "" Posn
p (Int -> Posn -> Posn
addcol 1 Posn
p) String
ss
                        (\p' :: Posn
p' i :: String
i-> String
-> TokenT
-> String
-> Posn
-> Posn
-> String
-> (Posn -> String -> [Token])
-> [Token]
textOrRefUntil String
close TokenT
tok "" 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 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 filename :: 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 p :: Posn
p s :: String
s
      | "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 7
      | "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 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 n :: 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 lookup :: String -> Maybe String
lookup p :: Posn
p s :: String
s =
    String
-> TokenT
-> String
-> Posn
-> Posn
-> String
-> (Posn -> String -> [Token])
-> [Token]
textOrRefUntil "%" TokenT
TokNull [] Posn
p Posn
p (ShowS
expand String
sString -> ShowS
forall a. [a] -> [a] -> [a]
++"%") ([Where] -> Posn -> String -> [Token]
xmlAny [])
  where
    expand :: ShowS
expand []       = []
    expand ('%':xs :: String
xs) = let (sym :: String
sym,rest :: 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
==';') String
xs in
                      case String -> Maybe String
lookup String
sym of
                        Just val :: String
val -> ShowS
expand String
val String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
expand (ShowS
forall a. [a] -> [a]
tail String
rest)
                        Nothing  -> "%"String -> ShowS
forall a. [a] -> [a] -> [a]
++String
symString -> ShowS
forall a. [a] -> [a] -> [a]
++";"String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
expand (ShowS
forall a. [a] -> [a]
tail String
rest) -- hmmm
    expand (x :: Char
x:xs :: 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      w :: [Where]
w p :: Posn
p s :: String
s = Posn -> String -> String -> (Posn -> String -> [Token]) -> [Token]
xmlName Posn
p String
s "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   w :: [Where]
w p :: Posn
p s :: String
s = String
-> TokenT
-> String
-> Posn
-> Posn
-> String
-> (Posn -> String -> [Token])
-> [Token]
textUntil "?>"  TokenT
TokPIClose "" 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 w :: [Where]
w p :: Posn
p s :: String
s = String
-> TokenT
-> String
-> Posn
-> Posn
-> String
-> (Posn -> String -> [Token])
-> [Token]
textUntil "-->" TokenT
TokCommentClose "" 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 t :: String
t:_)  p :: Posn
p [] = String -> Posn -> [Token]
lexerror ("unexpected EOF within "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
t) Posn
p
xmlAny          _    _ [] = []
xmlAny w :: [Where]
w p :: Posn
p s :: String
s@('<':ss :: String
ss)
    | "?"   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 2 Posn
p String
s ([Where] -> Posn -> String -> [Token]
xmlPI (String -> Where
InTag "<?...?>"Where -> [Where] -> [Where]
forall a. a -> [a] -> [a]
:[Where]
w))
    | "!--" 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 4 Posn
p String
s ([Where] -> Posn -> String -> [Token]
xmlComment [Where]
w)
    | "!["  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 3 Posn
p String
s ([Where] -> Posn -> String -> [Token]
xmlSection [Where]
w)
    | "!"   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 2 Posn
p String
s ([Where] -> Posn -> String -> [Token]
xmlSpecial (String -> Where
InTag "<!...>"Where -> [Where] -> [Where]
forall a. a -> [a] -> [a]
:[Where]
w))
    | "/"   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 2 Posn
p String
s ([Where] -> Posn -> String -> [Token]
xmlTag (String -> Where
InTag "</...>"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 1 Posn
p String
s ([Where] -> Posn -> String -> [Token]
xmlTag (String -> Where
InTag "<...>"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 xs :: [Where]
xs = [Where] -> [Where]
forall a. [a] -> [a]
tail [Where]
xs
xmlAny (_:_:w :: [Where]
w) p :: Posn
p s :: String
s@('/':ss :: String
ss)
    | ">"   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 2 Posn
p String
s ([Where] -> Posn -> String -> [Token]
xmlAny [Where]
w)
xmlAny w :: [Where]
w p :: Posn
p ('&':ss :: 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 ";" TokenT
TokSemi "" Posn
p
                                                     (Int -> Posn -> Posn
addcol 1 Posn
p) String
ss ([Where] -> Posn -> String -> [Token]
xmlAny [Where]
w)
xmlAny w :: [Where]
w@(NotInTag:_) p :: Posn
p s :: String
s = String -> [Where] -> Posn -> Posn -> String -> [Token]
xmlContent "" [Where]
w Posn
p Posn
p String
s
-- everything below here is implicitly InTag.
xmlAny w :: [Where]
w p :: Posn
p ('>':ss :: 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 1 Posn
p) String
ss
xmlAny w :: [Where]
w p :: Posn
p ('[':ss :: 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 "[...]"Where -> [Where] -> [Where]
forall a. a -> [a] -> [a]
:[Where]
w) (Int -> Posn -> Posn
addcol 1 Posn
p) String
ss
xmlAny w :: [Where]
w p :: Posn
p (']':ss :: String
ss)
    | "]>" 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 3 Posn
p (']'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 1 Posn
p) String
ss
xmlAny w :: [Where]
w p :: Posn
p ('(':ss :: 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 "(...)"Where -> [Where] -> [Where]
forall a. a -> [a] -> [a]
:[Where]
w) (Int -> Posn -> Posn
addcol 1 Posn
p) String
ss
xmlAny w :: [Where]
w p :: Posn
p (')':ss :: 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 1 Posn
p) String
ss
xmlAny w :: [Where]
w p :: Posn
p ('=':ss :: 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 1 Posn
p) String
ss
xmlAny w :: [Where]
w p :: Posn
p ('*':ss :: 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 1 Posn
p) String
ss
xmlAny w :: [Where]
w p :: Posn
p ('+':ss :: 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 1 Posn
p) String
ss
xmlAny w :: [Where]
w p :: Posn
p ('?':ss :: 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 1 Posn
p) String
ss
xmlAny w :: [Where]
w p :: Posn
p ('|':ss :: 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 1 Posn
p) String
ss
xmlAny w :: [Where]
w p :: Posn
p ('%':ss :: 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 1 Posn
p) String
ss
xmlAny w :: [Where]
w p :: Posn
p (';':ss :: 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 1 Posn
p) String
ss
xmlAny w :: [Where]
w p :: Posn
p (',':ss :: 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 1 Posn
p) String
ss
xmlAny w :: [Where]
w p :: Posn
p ('#':ss :: 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 1 Posn
p) String
ss
xmlAny w :: [Where]
w p :: Posn
p ('"':ss :: 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 "\"" TokenT
TokQuote "" Posn
p1
                                                          Posn
p1 String
ss ([Where] -> Posn -> String -> [Token]
xmlAny [Where]
w)
                                             where p1 :: Posn
p1 = Int -> Posn -> Posn
addcol 1 Posn
p
xmlAny w :: [Where]
w p :: Posn
p ('\'':ss :: 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 "'" TokenT
TokQuote "" Posn
p1
                                                          Posn
p1 String
ss ([Where] -> Posn -> String -> [Token]
xmlAny [Where]
w)
                                             where p1 :: Posn
p1 = Int -> Posn -> Posn
addcol 1 Posn
p
xmlAny w :: [Where]
w p :: Posn
p s :: 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`":_"
                           = Posn -> String -> String -> (Posn -> String -> [Token]) -> [Token]
xmlName Posn
p String
s "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 ("unrecognised token: "String -> ShowS
forall a. [a] -> [a] -> [a]
++Int -> ShowS
forall a. Int -> [a] -> [a]
take 4 String
s) Posn
p

xmlTag :: [Where] -> Posn -> String -> [Token]
xmlTag w :: [Where]
w p :: Posn
p s :: String
s = Posn -> String -> String -> (Posn -> String -> [Token]) -> [Token]
xmlName Posn
p String
s "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 w :: [Where]
w p :: Posn
p s :: String
s
      | "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 6
      | "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 7
      | "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 6
      | "%"        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 1
      | Bool
otherwise = String -> Posn -> [Token]
lexerror ("expected CDATA, IGNORE, or INCLUDE, but got "
                             String -> ShowS
forall a. [a] -> [a] -> [a]
++Int -> ShowS
forall a. Int -> [a] -> [a]
take 7 String
s) Posn
p
    accum :: [Where] -> Posn -> String -> Int -> [Token]
accum w :: [Where]
w p :: Posn
p s :: String
s n :: 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 "]]>" TokenT
TokSectionClose "" 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 w :: [Where]
w p :: Posn
p s :: String
s n :: 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 w :: [Where]
w p :: Posn
p s :: String
s
    | "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 7
    | "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 7
    | "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 7
    | "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 6
    | "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 8
    | Bool
otherwise = String -> Posn -> [Token]
lexerror
                    ("expected DOCTYPE, ELEMENT, ENTITY, ATTLIST, or NOTATION,"
                    String -> ShowS
forall a. [a] -> [a] -> [a]
++" but got "String -> ShowS
forall a. [a] -> [a] -> [a]
++Int -> ShowS
forall a. Int -> [a] -> [a]
take 7 String
s) Posn
p
  where k :: Int -> [Token]
k n :: 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 p :: Posn
p (s :: Char
s:ss :: String
ss) cxt :: String
cxt k :: Posn -> String -> [Token]
k
    | Char -> Bool
isAlphaNum Char
s Bool -> Bool -> Bool
|| Char
sChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==':' Bool -> Bool -> Bool
|| Char
sChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='_'  = String
-> Posn -> Posn -> String -> (Posn -> String -> [Token]) -> [Token]
gatherName (Char
sChar -> ShowS
forall a. a -> [a] -> [a]
:[]) Posn
p (Int -> Posn -> Posn
addcol 1 Posn
p) String
ss Posn -> String -> [Token]
k
    | Bool
otherwise   = String -> Posn -> [Token]
lexerror ("expected a "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
cxtString -> ShowS
forall a. [a] -> [a] -> [a]
++", 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 acc :: String
acc pos :: Posn
pos p :: Posn
p [] k :: 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 acc :: String
acc pos :: Posn
pos p :: Posn
p (s :: Char
s:ss :: String
ss) k :: 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
-> Posn -> Posn -> String -> (Posn -> String -> [Token]) -> [Token]
gatherName (Char
sChar -> ShowS
forall a. a -> [a] -> [a]
:String
acc) Posn
pos (Int -> Posn -> Posn
addcol 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 p :: Posn
p [] cxt :: String
cxt _ = String -> Posn -> [Token]
lexerror ("expected a "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
cxtString -> ShowS
forall a. [a] -> [a] -> [a]
++", but got end of input") Posn
p

xmlContent :: [Char] -> [Where] -> Posn -> Posn -> [Char] -> [Token]
xmlContent :: String -> [Where] -> Posn -> Posn -> String -> [Token]
xmlContent acc :: String
acc _w :: [Where]
_w _pos :: Posn
_pos p :: 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 "unexpected EOF between tags" Posn
p
xmlContent acc :: String
acc  w :: [Where]
w  pos :: Posn
pos p :: Posn
p (s :: Char
s:ss :: String
ss)
    | Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
s "<&"    = {- 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 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