{-# LANGUAGE TypeSynonymInstances #-}

module Text.XML.Light.Lexer where

import Text.XML.Light.Types

import Data.Char (chr,isSpace)
import Numeric (readHex)
import qualified Data.ByteString      as S
import qualified Data.ByteString.Lazy as L
import qualified Data.Text            as TS
import qualified Data.Text.Lazy       as TL


class XmlSource s where
  uncons :: s -> Maybe (Char,s)

instance XmlSource String where
  uncons :: String -> Maybe (Char, String)
uncons (Char
c:String
s) = (Char, String) -> Maybe (Char, String)
forall a. a -> Maybe a
Just (Char
c,String
s)
  uncons String
""    = Maybe (Char, String)
forall a. Maybe a
Nothing

instance XmlSource S.ByteString where
  uncons :: ByteString -> Maybe (Char, ByteString)
uncons ByteString
bs = (Word8, ByteString) -> (Char, ByteString)
forall {a} {b}. Enum a => (a, b) -> (Char, b)
f ((Word8, ByteString) -> (Char, ByteString))
-> Maybe (Word8, ByteString) -> Maybe (Char, ByteString)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ByteString -> Maybe (Word8, ByteString)
S.uncons ByteString
bs
    where f :: (a, b) -> (Char, b)
f (a
c,b
s) = (Int -> Char
chr (a -> Int
forall a. Enum a => a -> Int
fromEnum a
c), b
s)

instance XmlSource L.ByteString where
  uncons :: ByteString -> Maybe (Char, ByteString)
uncons ByteString
bs = (Word8, ByteString) -> (Char, ByteString)
forall {a} {b}. Enum a => (a, b) -> (Char, b)
f ((Word8, ByteString) -> (Char, ByteString))
-> Maybe (Word8, ByteString) -> Maybe (Char, ByteString)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ByteString -> Maybe (Word8, ByteString)
L.uncons ByteString
bs
    where f :: (a, b) -> (Char, b)
f (a
c,b
s) = (Int -> Char
chr (a -> Int
forall a. Enum a => a -> Int
fromEnum a
c), b
s)

instance XmlSource TS.Text where
  uncons :: Text -> Maybe (Char, Text)
uncons = Text -> Maybe (Char, Text)
TS.uncons

instance XmlSource TL.Text where
  uncons :: Text -> Maybe (Char, Text)
uncons = Text -> Maybe (Char, Text)
TL.uncons

linenumber :: XmlSource s => Integer -> s -> LString
linenumber :: forall s. XmlSource s => Integer -> s -> LString
linenumber Integer
n s
s = case s -> Maybe (Char, s)
forall s. XmlSource s => s -> Maybe (Char, s)
uncons s
s of
  Maybe (Char, s)
Nothing -> []
  Just (Char
'\r', s
s')   -> case s -> Maybe (Char, s)
forall s. XmlSource s => s -> Maybe (Char, s)
uncons s
s' of
    Just (Char
'\n',s
s'') -> s -> LString
forall {s}. XmlSource s => s -> LString
next s
s''
    Maybe (Char, s)
_               -> s -> LString
forall {s}. XmlSource s => s -> LString
next s
s'
  Just (Char
'\n', s
s') -> s -> LString
forall {s}. XmlSource s => s -> LString
next s
s'
  Just (Char
c   , s
s') -> (Integer
n,Char
c) LChar -> LString -> LString
forall a. a -> [a] -> [a]
: Integer -> s -> LString
forall s. XmlSource s => Integer -> s -> LString
linenumber Integer
n s
s'
  where
  next :: s -> LString
next s
s' = Integer
n' Integer -> LString -> LString
forall a b. a -> b -> b
`seq` ((Integer
n,Char
'\n')LChar -> LString -> LString
forall a. a -> [a] -> [a]
:Integer -> s -> LString
forall s. XmlSource s => Integer -> s -> LString
linenumber Integer
n' s
s') where n' :: Integer
n' = Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1


-- | This type may be used to provide a custom scanning function
-- for extracting characters.
data Scanner s = Scanner (Maybe (Char,s)) (s -> Maybe (Char,s))

-- | This type may be used to provide a custom scanning function
-- for extracting characters.
customScanner :: (s -> Maybe (Char,s)) -> s -> Scanner s
customScanner :: forall s. (s -> Maybe (Char, s)) -> s -> Scanner s
customScanner s -> Maybe (Char, s)
next s
s = Maybe (Char, s) -> (s -> Maybe (Char, s)) -> Scanner s
forall s. Maybe (Char, s) -> (s -> Maybe (Char, s)) -> Scanner s
Scanner (s -> Maybe (Char, s)
next s
s) s -> Maybe (Char, s)
next

instance XmlSource (Scanner s) where
  uncons :: Scanner s -> Maybe (Char, Scanner s)
uncons (Scanner Maybe (Char, s)
this s -> Maybe (Char, s)
next) = do (Char
c,s
s1) <- Maybe (Char, s)
this
                                  (Char, Scanner s) -> Maybe (Char, Scanner s)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
c, Maybe (Char, s) -> (s -> Maybe (Char, s)) -> Scanner s
forall s. Maybe (Char, s) -> (s -> Maybe (Char, s)) -> Scanner s
Scanner (s -> Maybe (Char, s)
next s
s1) s -> Maybe (Char, s)
next)


-- Lexer -----------------------------------------------------------------------

type LChar              = (Line,Char)
type LString            = [LChar]
data Token              = TokStart Line QName [Attr] Bool  -- is empty?
                        | TokEnd Line QName
                        | TokCRef String
                        | TokText CData
                          deriving Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
(Int -> Token -> ShowS)
-> (Token -> String) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Token -> ShowS
showsPrec :: Int -> Token -> ShowS
$cshow :: Token -> String
show :: Token -> String
$cshowList :: [Token] -> ShowS
showList :: [Token] -> ShowS
Show

tokens             :: XmlSource source => source -> [Token]
tokens :: forall source. XmlSource source => source -> [Token]
tokens = LString -> [Token]
tokens' (LString -> [Token]) -> (source -> LString) -> source -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> source -> LString
forall s. XmlSource s => Integer -> s -> LString
linenumber Integer
1

tokens' :: LString -> [Token]
tokens' :: LString -> [Token]
tokens' ((Integer
_,Char
'<') : c :: LChar
c@(Integer
_,Char
'!') : LString
cs) = LChar -> LString -> [Token]
special LChar
c LString
cs

tokens' ((Integer
_,Char
'<') : LString
cs)   = LString -> [Token]
tag (LString -> LString
dropSpace LString
cs) -- we are being nice here
tokens' [] = []
tokens' cs :: LString
cs@((Integer
l,Char
_):LString
_) = let (String
as,LString
bs) = (Char -> Bool) -> LString -> (String, LString)
forall a b. (a -> Bool) -> [(b, a)] -> ([a], [(b, a)])
breakn (Char
'<' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) LString
cs
                       in (Txt -> Token) -> [Txt] -> [Token]
forall a b. (a -> b) -> [a] -> [b]
map Txt -> Token
cvt (String -> [Txt]
decode_text String
as) [Token] -> [Token] -> [Token]
forall a. [a] -> [a] -> [a]
++ LString -> [Token]
tokens' LString
bs

  -- XXX: Note, some of the lines might be a bit inacuarate
  where cvt :: Txt -> Token
cvt (TxtBit String
x)  = CData -> Token
TokText CData { cdLine :: Maybe Integer
cdLine = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
l
                                        , cdVerbatim :: CDataKind
cdVerbatim = CDataKind
CDataText
                                        , cdData :: String
cdData = String
x
                                        }
        cvt (CRefBit String
x) = case String -> Maybe Char
cref_to_char String
x of
                            Just Char
c -> CData -> Token
TokText CData { cdLine :: Maybe Integer
cdLine = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
l
                                                    , cdVerbatim :: CDataKind
cdVerbatim = CDataKind
CDataText
                                                    , cdData :: String
cdData = [Char
c]
                                                    }
                            Maybe Char
Nothing -> String -> Token
TokCRef String
x


special :: LChar -> LString -> [Token]
special :: LChar -> LString -> [Token]
special LChar
_ ((Integer
_,Char
'-') : (Integer
_,Char
'-') : LString
cs) = LString -> [Token]
skip LString
cs
  where skip :: LString -> [Token]
skip ((Integer
_,Char
'-') : (Integer
_,Char
'-') : (Integer
_,Char
'>') : LString
ds) = LString -> [Token]
tokens' LString
ds
        skip (LChar
_ : LString
ds) = LString -> [Token]
skip LString
ds
        skip [] = [] -- unterminated comment

special LChar
c ((Integer
_,Char
'[') : (Integer
_,Char
'C') : (Integer
_,Char
'D') : (Integer
_,Char
'A') : (Integer
_,Char
'T') : (Integer
_,Char
'A') : (Integer
_,Char
'[')
         : LString
cs) =
  let (String
xs,LString
ts) = LString -> (String, LString)
forall {a}. [(a, Char)] -> (String, [(a, Char)])
cdata LString
cs
  in CData -> Token
TokText CData { cdLine :: Maybe Integer
cdLine = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (LChar -> Integer
forall a b. (a, b) -> a
fst LChar
c), cdVerbatim :: CDataKind
cdVerbatim = CDataKind
CDataVerbatim, cdData :: String
cdData = String
xs }
                                                                  Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: LString -> [Token]
tokens' LString
ts
  where cdata :: [(a, Char)] -> (String, [(a, Char)])
cdata ((a
_,Char
']') : (a
_,Char
']') : (a
_,Char
'>') : [(a, Char)]
ds) = ([],[(a, Char)]
ds)
        cdata ((a
_,Char
d) : [(a, Char)]
ds)  = let (String
xs,[(a, Char)]
ys) = [(a, Char)] -> (String, [(a, Char)])
cdata [(a, Char)]
ds in (Char
dChar -> ShowS
forall a. a -> [a] -> [a]
:String
xs,[(a, Char)]
ys)
        cdata []        = ([],[])

special LChar
c LString
cs = 
  let (String
xs,LString
ts) = String -> Int -> LString -> (String, LString)
forall {a}. String -> Int -> [(a, Char)] -> (String, [(a, Char)])
munch String
"" Int
0 LString
cs
  in CData -> Token
TokText CData { cdLine :: Maybe Integer
cdLine = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (LChar -> Integer
forall a b. (a, b) -> a
fst LChar
c)
                   , cdVerbatim :: CDataKind
cdVerbatim = CDataKind
CDataRaw
                   , cdData :: String
cdData = Char
'<'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'!'Char -> ShowS
forall a. a -> [a] -> [a]
:(ShowS
forall a. [a] -> [a]
reverse String
xs)
                   } Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: LString -> [Token]
tokens' LString
ts
  where munch :: String -> Int -> [(a, Char)] -> (String, [(a, Char)])
munch String
acc Int
nesting ((a
_,Char
'>') : [(a, Char)]
ds) 
         | Int
nesting Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Int
0::Int) = (Char
'>'Char -> ShowS
forall a. a -> [a] -> [a]
:String
acc,[(a, Char)]
ds)
	 | Bool
otherwise           = String -> Int -> [(a, Char)] -> (String, [(a, Char)])
munch (Char
'>'Char -> ShowS
forall a. a -> [a] -> [a]
:String
acc) (Int
nestingInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [(a, Char)]
ds
        munch String
acc Int
nesting ((a
_,Char
'<') : [(a, Char)]
ds)
	 = String -> Int -> [(a, Char)] -> (String, [(a, Char)])
munch (Char
'<'Char -> ShowS
forall a. a -> [a] -> [a]
:String
acc) (Int
nestingInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [(a, Char)]
ds
        munch String
acc Int
n ((a
_,Char
x) : [(a, Char)]
ds) = String -> Int -> [(a, Char)] -> (String, [(a, Char)])
munch (Char
xChar -> ShowS
forall a. a -> [a] -> [a]
:String
acc) Int
n [(a, Char)]
ds
        munch String
acc Int
_ [] = (String
acc,[]) -- unterminated DTD markup

--special c cs = tag (c : cs) -- invalid specials are processed as tags


qualName           :: LString -> (QName,LString)
qualName :: LString -> (QName, LString)
qualName LString
xs         = let (String
as,LString
bs) = (Char -> Bool) -> LString -> (String, LString)
forall a b. (a -> Bool) -> [(b, a)] -> ([a], [(b, a)])
breakn Char -> Bool
endName LString
xs
                          (Maybe String
q,String
n)   = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char
':'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) String
as of
                                      (String
q1,Char
_:String
n1) -> (String -> Maybe String
forall a. a -> Maybe a
Just String
q1, String
n1)
                                      (String, String)
_         -> (Maybe String
forall a. Maybe a
Nothing, String
as)
                      in (QName { qURI :: Maybe String
qURI = Maybe String
forall a. Maybe a
Nothing, qPrefix :: Maybe String
qPrefix = Maybe String
q, qName :: String
qName = String
n }, LString
bs)
  where endName :: Char -> Bool
endName Char
x = Char -> Bool
isSpace Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'>' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/'





tag              :: LString -> [Token]
tag :: LString -> [Token]
tag ((Integer
p,Char
'/') : LString
cs)    = let (QName
n,LString
ds) = LString -> (QName, LString)
qualName (LString -> LString
dropSpace LString
cs)
                        in Integer -> QName -> Token
TokEnd Integer
p QName
n Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: case (LString -> LString
dropSpace LString
ds) of
                                          (Integer
_,Char
'>') : LString
es -> LString -> [Token]
tokens' LString
es
                                          -- tag was not properly closed...
                                          LString
_        -> LString -> [Token]
tokens' LString
ds
tag []            = []
tag LString
cs            = let (QName
n,LString
ds)  = LString -> (QName, LString)
qualName LString
cs
                        ([Attr]
as,Bool
b,[Token]
ts) = LString -> ([Attr], Bool, [Token])
attribs (LString -> LString
dropSpace LString
ds)
                    in Integer -> QName -> [Attr] -> Bool -> Token
TokStart (LChar -> Integer
forall a b. (a, b) -> a
fst (LString -> LChar
forall a. HasCallStack => [a] -> a
head LString
cs)) QName
n [Attr]
as Bool
b Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
ts

attribs          :: LString -> ([Attr], Bool, [Token])
attribs :: LString -> ([Attr], Bool, [Token])
attribs LString
cs        = case LString
cs of
                      (Integer
_,Char
'>') : LString
ds -> ([], Bool
False, LString -> [Token]
tokens' LString
ds)

                      (Integer
_,Char
'/') : LString
ds -> ([], Bool
True, case LString
ds of
                                              (Integer
_,Char
'>') : LString
es -> LString -> [Token]
tokens' LString
es
                                              -- insert missing >  ...
                                              LString
_ -> LString -> [Token]
tokens' LString
ds)

                      (Integer
_,Char
'?') : (Integer
_,Char
'>') : LString
ds -> ([], Bool
True, LString -> [Token]
tokens' LString
ds)

                      -- doc ended within a tag..
                      []       -> ([],Bool
False,[])

                      LString
_        -> let (Attr
a,LString
cs1) = LString -> (Attr, LString)
attrib LString
cs
                                      ([Attr]
as,Bool
b,[Token]
ts) = LString -> ([Attr], Bool, [Token])
attribs LString
cs1
                                  in (Attr
aAttr -> [Attr] -> [Attr]
forall a. a -> [a] -> [a]
:[Attr]
as,Bool
b,[Token]
ts)

attrib             :: LString -> (Attr,LString)
attrib :: LString -> (Attr, LString)
attrib LString
cs           = let (QName
ks,LString
cs1)  = LString -> (QName, LString)
qualName LString
cs
                          (String
vs,LString
cs2)  = LString -> (String, LString)
attr_val (LString -> LString
dropSpace LString
cs1)
                      in ((QName -> String -> Attr
Attr QName
ks (ShowS
decode_attr String
vs)),LString -> LString
dropSpace LString
cs2)

attr_val           :: LString -> (String,LString)
attr_val :: LString -> (String, LString)
attr_val ((Integer
_,Char
'=') : LString
cs) = LString -> (String, LString)
string (LString -> LString
dropSpace LString
cs)
attr_val LString
cs         = (String
"",LString
cs)


dropSpace :: LString -> LString
dropSpace :: LString -> LString
dropSpace = (LChar -> Bool) -> LString -> LString
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Bool
isSpace (Char -> Bool) -> (LChar -> Char) -> LChar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LChar -> Char
forall a b. (a, b) -> b
snd)

-- | Match the value for an attribute.  For malformed XML we do
-- our best to guess the programmer's intention.
string             :: LString -> (String,LString)
string :: LString -> (String, LString)
string ((Integer
_,Char
'"') : LString
cs)   = (Char -> Bool) -> LString -> (String, LString)
forall a b. (a -> Bool) -> [(b, a)] -> ([a], [(b, a)])
break' (Char
'"' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) LString
cs

-- Allow attributes to be enclosed between ' '.
string ((Integer
_,Char
'\'') : LString
cs)  = (Char -> Bool) -> LString -> (String, LString)
forall a b. (a -> Bool) -> [(b, a)] -> ([a], [(b, a)])
break' (Char
'\'' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) LString
cs

-- Allow attributes that are not enclosed by anything.
string LString
cs           = (Char -> Bool) -> LString -> (String, LString)
forall a b. (a -> Bool) -> [(b, a)] -> ([a], [(b, a)])
breakn Char -> Bool
eos LString
cs
  where eos :: Char -> Bool
eos Char
x = Char -> Bool
isSpace Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'>' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/'


break' :: (a -> Bool) -> [(b,a)] -> ([a],[(b,a)])
break' :: forall a b. (a -> Bool) -> [(b, a)] -> ([a], [(b, a)])
break' a -> Bool
p [(b, a)]
xs         = let ([a]
as,[(b, a)]
bs) = (a -> Bool) -> [(b, a)] -> ([a], [(b, a)])
forall a b. (a -> Bool) -> [(b, a)] -> ([a], [(b, a)])
breakn a -> Bool
p [(b, a)]
xs
                      in ([a]
as, case [(b, a)]
bs of
                                [] -> []
                                (b, a)
_ : [(b, a)]
cs -> [(b, a)]
cs)

breakn :: (a -> Bool) -> [(b,a)] -> ([a],[(b,a)])
breakn :: forall a b. (a -> Bool) -> [(b, a)] -> ([a], [(b, a)])
breakn a -> Bool
p [(b, a)]
l = (((b, a) -> a) -> [(b, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (b, a) -> a
forall a b. (a, b) -> b
snd [(b, a)]
as,[(b, a)]
bs) where ([(b, a)]
as,[(b, a)]
bs) = ((b, a) -> Bool) -> [(b, a)] -> ([(b, a)], [(b, a)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (a -> Bool
p (a -> Bool) -> ((b, a) -> a) -> (b, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b, a) -> a
forall a b. (a, b) -> b
snd) [(b, a)]
l



decode_attr :: String -> String
decode_attr :: ShowS
decode_attr String
cs = (Txt -> String) -> [Txt] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Txt -> String
cvt (String -> [Txt]
decode_text String
cs)
  where cvt :: Txt -> String
cvt (TxtBit String
x) = String
x
        cvt (CRefBit String
x) = case String -> Maybe Char
cref_to_char String
x of
                            Just Char
c -> [Char
c]
                            Maybe Char
Nothing -> Char
'&' Char -> ShowS
forall a. a -> [a] -> [a]
: String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
";"

data Txt = TxtBit String | CRefBit String deriving Int -> Txt -> ShowS
[Txt] -> ShowS
Txt -> String
(Int -> Txt -> ShowS)
-> (Txt -> String) -> ([Txt] -> ShowS) -> Show Txt
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Txt -> ShowS
showsPrec :: Int -> Txt -> ShowS
$cshow :: Txt -> String
show :: Txt -> String
$cshowList :: [Txt] -> ShowS
showList :: [Txt] -> ShowS
Show

decode_text :: [Char] -> [Txt]
decode_text :: String -> [Txt]
decode_text xs :: String
xs@(Char
'&' : String
cs) = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char
';' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) String
cs of
                              (String
as,Char
_:String
bs) -> String -> Txt
CRefBit String
as Txt -> [Txt] -> [Txt]
forall a. a -> [a] -> [a]
: String -> [Txt]
decode_text String
bs
                              (String, String)
_ -> [String -> Txt
TxtBit String
xs]
decode_text []  = []
decode_text String
cs  = let (String
as,String
bs) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char
'&' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) String
cs
                  in String -> Txt
TxtBit String
as Txt -> [Txt] -> [Txt]
forall a. a -> [a] -> [a]
: String -> [Txt]
decode_text String
bs

cref_to_char :: [Char] -> Maybe Char
cref_to_char :: String -> Maybe Char
cref_to_char String
cs = case String
cs of
  Char
'#' : String
ds  -> String -> Maybe Char
num_esc String
ds
  String
"lt"      -> Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'<'
  String
"gt"      -> Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'>'
  String
"amp"     -> Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'&'
  String
"apos"    -> Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'\''
  String
"quot"    -> Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'"'
  String
_         -> Maybe Char
forall a. Maybe a
Nothing

num_esc :: String -> Maybe Char
num_esc :: String -> Maybe Char
num_esc String
cs = case String
cs of
               Char
'x' : String
ds -> [(Int, String)] -> Maybe Char
check (ReadS Int
forall a. (Eq a, Num a) => ReadS a
readHex String
ds)
               String
_        -> [(Int, String)] -> Maybe Char
check (ReadS Int
forall a. Read a => ReadS a
reads String
cs)

  where check :: [(Int, String)] -> Maybe Char
check [(Int
n,String
"")]  = Int -> Maybe Char
cvt_char Int
n
        check [(Int, String)]
_         = Maybe Char
forall a. Maybe a
Nothing

cvt_char :: Int -> Maybe Char
cvt_char :: Int -> Maybe Char
cvt_char Int
x
  | Char -> Int
forall a. Enum a => a -> Int
fromEnum (Char
forall a. Bounded a => a
minBound :: Char) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
x Bool -> Bool -> Bool
&& Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Char -> Int
forall a. Enum a => a -> Int
fromEnum (Char
forall a. Bounded a => a
maxBound::Char)
                = Char -> Maybe Char
forall a. a -> Maybe a
Just (Int -> Char
forall a. Enum a => Int -> a
toEnum Int
x)
  | Bool
otherwise = Maybe Char
forall a. Maybe a
Nothing