{-# 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 (c :: Char
c:s :: String
s) = (Char, String) -> Maybe (Char, String)
forall a. a -> Maybe a
Just (Char
c,String
s)
  uncons ""    = Maybe (Char, String)
forall a. Maybe a
Nothing

instance XmlSource S.ByteString where
  uncons :: ByteString -> Maybe (Char, ByteString)
uncons bs :: 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 (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 (c :: a
c,s :: 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 bs :: 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 (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 (c :: a
c,s :: 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 :: Integer -> s -> LString
linenumber n :: Integer
n s :: s
s = case s -> Maybe (Char, s)
forall s. XmlSource s => s -> Maybe (Char, s)
uncons s
s of
  Nothing -> []
  Just ('\r', s' :: s
s')   -> case s -> Maybe (Char, s)
forall s. XmlSource s => s -> Maybe (Char, s)
uncons s
s' of
    Just ('\n',s'' :: s
s'') -> s -> LString
forall s. XmlSource s => s -> LString
next s
s''
    _               -> s -> LString
forall s. XmlSource s => s -> LString
next s
s'
  Just ('\n', s' :: s
s') -> s -> LString
forall s. XmlSource s => s -> LString
next s
s'
  Just (c :: Char
c   , s' :: s
s') -> (Integer
n,Char
c) (Integer, Char) -> 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
s' = Integer
n' Integer -> LString -> LString
forall a b. a -> b -> b
`seq` ((Integer
n,'\n')(Integer, Char) -> 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
+ 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 :: (s -> Maybe (Char, s)) -> s -> Scanner s
customScanner next :: s -> Maybe (Char, s)
next s :: 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 this :: Maybe (Char, s)
this next :: s -> Maybe (Char, s)
next) = do (c :: Char
c,s1 :: s
s1) <- Maybe (Char, s)
this
                                  (Char, Scanner s) -> Maybe (Char, Scanner s)
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
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> String
$cshow :: Token -> String
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show

tokens             :: XmlSource source => source -> [Token]
tokens :: 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 1

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

tokens' ((_,'<') : cs :: LString
cs)   = LString -> [Token]
tag (LString -> LString
dropSpace LString
cs) -- we are being nice here
tokens' [] = []
tokens' cs :: LString
cs@((l :: Integer
l,_):_) = let (as :: String
as,bs :: LString
bs) = (Char -> Bool) -> LString -> (String, LString)
forall a b. (a -> Bool) -> [(b, a)] -> ([a], [(b, a)])
breakn ('<' 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 x :: String
x)  = CData -> Token
TokText CData :: CDataKind -> String -> Maybe Integer -> CData
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 x :: String
x) = case String -> Maybe Char
cref_to_char String
x of
                            Just c :: Char
c -> CData -> Token
TokText CData :: CDataKind -> String -> Maybe Integer -> CData
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]
                                                    }
                            Nothing -> String -> Token
TokCRef String
x


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

special c :: (Integer, Char)
c ((_,'[') : (_,'C') : (_,'D') : (_,'A') : (_,'T') : (_,'A') : (_,'[')
         : cs :: LString
cs) =
  let (xs :: String
xs,ts :: LString
ts) = LString -> (String, LString)
forall a. [(a, Char)] -> (String, [(a, Char)])
cdata LString
cs
  in CData -> Token
TokText CData :: CDataKind -> String -> Maybe Integer -> CData
CData { cdLine :: Maybe Integer
cdLine = Integer -> Maybe Integer
forall a. a -> Maybe a
Just ((Integer, Char) -> Integer
forall a b. (a, b) -> a
fst (Integer, Char)
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 ((_,']') : (_,']') : (_,'>') : ds :: [(a, Char)]
ds) = ([],[(a, Char)]
ds)
        cdata ((_,d :: Char
d) : ds :: [(a, Char)]
ds)  = let (xs :: String
xs,ys :: [(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 c :: (Integer, Char)
c cs :: LString
cs = 
  let (xs :: String
xs,ts :: LString
ts) = String -> Int -> LString -> (String, LString)
forall a. String -> Int -> [(a, Char)] -> (String, [(a, Char)])
munch "" 0 LString
cs
  in CData -> Token
TokText CData :: CDataKind -> String -> Maybe Integer -> CData
CData { cdLine :: Maybe Integer
cdLine = Integer -> Maybe Integer
forall a. a -> Maybe a
Just ((Integer, Char) -> Integer
forall a b. (a, b) -> a
fst (Integer, Char)
c)
                   , cdVerbatim :: CDataKind
cdVerbatim = CDataKind
CDataRaw
                   , cdData :: String
cdData = '<'Char -> ShowS
forall a. a -> [a] -> [a]
:'!'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 acc :: String
acc nesting :: Int
nesting ((_,'>') : ds :: [(a, Char)]
ds) 
         | Int
nesting Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (0::Int) = ('>'Char -> ShowS
forall a. a -> [a] -> [a]
:String
acc,[(a, Char)]
ds)
	 | Bool
otherwise           = String -> Int -> [(a, Char)] -> (String, [(a, Char)])
munch ('>'Char -> ShowS
forall a. a -> [a] -> [a]
:String
acc) (Int
nestingInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) [(a, Char)]
ds
        munch acc :: String
acc nesting :: Int
nesting ((_,'<') : ds :: [(a, Char)]
ds)
	 = String -> Int -> [(a, Char)] -> (String, [(a, Char)])
munch ('<'Char -> ShowS
forall a. a -> [a] -> [a]
:String
acc) (Int
nestingInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) [(a, Char)]
ds
        munch acc :: String
acc n :: Int
n ((_,x :: Char
x) : ds :: [(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 acc :: String
acc _ [] = (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 xs :: LString
xs         = let (as :: String
as,bs :: LString
bs) = (Char -> Bool) -> LString -> (String, LString)
forall a b. (a -> Bool) -> [(b, a)] -> ([a], [(b, a)])
breakn Char -> Bool
endName LString
xs
                          (q :: Maybe String
q,n :: String
n)   = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (':'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) String
as of
                                      (q1 :: String
q1,_:n1 :: String
n1) -> (String -> Maybe String
forall a. a -> Maybe a
Just String
q1, String
n1)
                                      _         -> (Maybe String
forall a. Maybe a
Nothing, String
as)
                      in (QName :: String -> Maybe String -> Maybe String -> QName
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 x :: Char
x = Char -> Bool
isSpace Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '=' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '>' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '/'





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

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

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

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

                      _        -> let (a :: Attr
a,cs1 :: LString
cs1) = LString -> (Attr, LString)
attrib LString
cs
                                      (as :: [Attr]
as,b :: Bool
b,ts :: [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 cs :: LString
cs           = let (ks :: QName
ks,cs1 :: LString
cs1)  = LString -> (QName, LString)
qualName LString
cs
                          (vs :: String
vs,cs2 :: 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 ((_,'=') : cs :: LString
cs) = LString -> (String, LString)
string (LString -> LString
dropSpace LString
cs)
attr_val cs :: LString
cs         = ("",LString
cs)


dropSpace :: LString -> LString
dropSpace :: LString -> LString
dropSpace = ((Integer, Char) -> Bool) -> LString -> LString
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Bool
isSpace (Char -> Bool)
-> ((Integer, Char) -> Char) -> (Integer, Char) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer, Char) -> 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 ((_,'"') : cs :: LString
cs)   = (Char -> Bool) -> LString -> (String, LString)
forall a b. (a -> Bool) -> [(b, a)] -> ([a], [(b, a)])
break' ('"' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) LString
cs

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

-- Allow attributes that are not enclosed by anything.
string cs :: 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 x :: Char
x = Char -> Bool
isSpace Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '>' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '/'


break' :: (a -> Bool) -> [(b,a)] -> ([a],[(b,a)])
break' :: (a -> Bool) -> [(b, a)] -> ([a], [(b, a)])
break' p :: a -> Bool
p xs :: [(b, a)]
xs         = let (as :: [a]
as,bs :: [(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
                                [] -> []
                                _ : cs :: [(b, a)]
cs -> [(b, a)]
cs)

breakn :: (a -> Bool) -> [(b,a)] -> ([a],[(b,a)])
breakn :: (a -> Bool) -> [(b, a)] -> ([a], [(b, a)])
breakn p :: a -> Bool
p l :: [(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 (as :: [(b, a)]
as,bs :: [(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 cs :: 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 x :: String
x) = String
x
        cvt (CRefBit x :: String
x) = case String -> Maybe Char
cref_to_char String
x of
                            Just c :: Char
c -> [Char
c]
                            Nothing -> '&' Char -> ShowS
forall a. a -> [a] -> [a]
: String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ ";"

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
showList :: [Txt] -> ShowS
$cshowList :: [Txt] -> ShowS
show :: Txt -> String
$cshow :: Txt -> String
showsPrec :: Int -> Txt -> ShowS
$cshowsPrec :: Int -> Txt -> ShowS
Show

decode_text :: [Char] -> [Txt]
decode_text :: String -> [Txt]
decode_text xs :: String
xs@('&' : cs :: String
cs) = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (';' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) String
cs of
                              (as :: String
as,_:bs :: String
bs) -> String -> Txt
CRefBit String
as Txt -> [Txt] -> [Txt]
forall a. a -> [a] -> [a]
: String -> [Txt]
decode_text String
bs
                              _ -> [String -> Txt
TxtBit String
xs]
decode_text []  = []
decode_text cs :: String
cs  = let (as :: String
as,bs :: String
bs) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ('&' 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 cs :: String
cs = case String
cs of
  '#' : ds :: String
ds  -> String -> Maybe Char
num_esc String
ds
  "lt"      -> Char -> Maybe Char
forall a. a -> Maybe a
Just '<'
  "gt"      -> Char -> Maybe Char
forall a. a -> Maybe a
Just '>'
  "amp"     -> Char -> Maybe Char
forall a. a -> Maybe a
Just '&'
  "apos"    -> Char -> Maybe Char
forall a. a -> Maybe a
Just '\''
  "quot"    -> Char -> Maybe Char
forall a. a -> Maybe a
Just '"'
  _         -> Maybe Char
forall a. Maybe a
Nothing

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

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

cvt_char :: Int -> Maybe Char
cvt_char :: Int -> Maybe Char
cvt_char x :: 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