module Text.XML.Basic.Entity (
   Name,
   list, listInternetExploder,
   mapNameToChar, mapCharToName,
   numberToChar,
   ) where

import qualified Data.Map as Map
import qualified Data.Char as Char
import Control.Monad.Exception.Synchronous (Exceptional, assert, throw, )
import Control.Monad.HT ((<=<), )
import Data.Monoid (Monoid(mempty, mappend), mconcat, )
import Data.Semigroup (Semigroup((<>)), )
import Data.Tuple.HT (swap, )


{- |
Lookup a numeric entity, the leading @\'#\'@ must have already been removed.

> numberToChar "65" == Success 'A'
> numberToChar "x41" == Success 'A'
> numberToChar "x4E" === Success 'N'
> numberToChar "x4e" === Success 'N'
> numberToChar "Haskell" == Exception "..."
> numberToChar "" == Exception "..."
> numberToChar "89439085908539082" == Exception "..."

It's safe to use that for arbitrary big number strings,
since we abort parsing as soon as possible.

> numberToChar (repeat '1') == Exception "..."
-}
numberToChar :: String -> Exceptional String Char
numberToChar :: Name -> Exceptional Name Char
numberToChar Name
s =
   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Char
Char.chr forall a b. (a -> b) -> a -> b
$
   case Name
s of
      (Char
'x':Name
ds) -> Int -> (Char -> Bool) -> Name -> Exceptional Name Int
readBounded Int
16 Char -> Bool
Char.isHexDigit Name
ds
      Name
ds       -> Int -> (Char -> Bool) -> Name -> Exceptional Name Int
readBounded Int
10 Char -> Bool
Char.isDigit    Name
ds

{- |
We fail on leading zeros in order to prevent infinite loop on @repeat '0'@.
This function assumes that @16 * ord maxBound@ is always representable as @Int@.
-}
readBounded :: Int -> (Char -> Bool) -> String -> Exceptional String Int
readBounded :: Int -> (Char -> Bool) -> Name -> Exceptional Name Int
readBounded Int
base Char -> Bool
validChar Name
str =
   case Name
str of
      Name
""  -> forall e a. e -> Exceptional e a
throw Name
"empty number string"
      Name
"0" -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
      Name
_ ->
         let m :: Char -> Update Name Int
m Char
digit =
               forall e a. (a -> Exceptional e a) -> Update e a
Update forall a b. (a -> b) -> a -> b
$ \Int
mostSig ->
                  let n :: Int
n = Int
mostSigforall a. Num a => a -> a -> a
*Int
base forall a. Num a => a -> a -> a
+ Char -> Int
Char.digitToInt Char
digit
                  in  forall e. e -> Bool -> Exceptional e ()
assert (Name
"invalid character "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> Name
show Char
digit)
                         (Char -> Bool
validChar Char
digit) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                      forall e. e -> Bool -> Exceptional e ()
assert Name
"leading zero not allowed for security reasons"
                         (Bool -> Bool
not (Int
mostSigforall a. Eq a => a -> a -> Bool
==Int
0 Bool -> Bool -> Bool
&& Char
digitforall a. Eq a => a -> a -> Bool
==Char
'0')) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                      forall e. e -> Bool -> Exceptional e ()
assert Name
"number too big"
                         (Int
n forall a. Ord a => a -> a -> Bool
<= Char -> Int
Char.ord forall a. Bounded a => a
maxBound) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                      forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
         in  forall e a. Update e a -> a -> Exceptional e a
evalUpdate (forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Char -> Update Name Int
m Name
str) Int
0


newtype Update e a = Update {forall e a. Update e a -> a -> Exceptional e a
evalUpdate :: a -> Exceptional e a}

instance Semigroup (Update e a) where
   Update a -> Exceptional e a
x <> :: Update e a -> Update e a -> Update e a
<> Update a -> Exceptional e a
y = forall e a. (a -> Exceptional e a) -> Update e a
Update (a -> Exceptional e a
y forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< a -> Exceptional e a
x)

instance Monoid (Update e a) where
   mempty :: Update e a
mempty = forall e a. (a -> Exceptional e a) -> Update e a
Update forall (m :: * -> *) a. Monad m => a -> m a
return
   mappend :: Update e a -> Update e a -> Update e a
mappend = forall a. Semigroup a => a -> a -> a
(<>)



type Name = String

mapNameToChar :: Map.Map Name Char
mapNameToChar :: Map Name Char
mapNameToChar =
   forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Name, Char)]
list

mapCharToName :: Map.Map Char Name
mapCharToName :: Map Char Name
mapCharToName =
   forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> (b, a)
swap [(Name, Char)]
list

{- |
A table mapping XML entity names to code points.
Although entity references can in principle represent more than one character,
the standard entities only contain one character.
-}
list :: [(Name, Char)]
list :: [(Name, Char)]
list =
   (Name
"apos",   Char
'\'') forall a. a -> [a] -> [a]
:
   [(Name, Char)]
listInternetExploder

{- |
This list excludes @apos@ as Internet Explorer does not know about it.
-}
listInternetExploder :: [(Name, Char)]
listInternetExploder :: [(Name, Char)]
listInternetExploder =
   (Name
"quot",   Char
'"') forall a. a -> [a] -> [a]
:
   (Name
"amp",    Char
'&') forall a. a -> [a] -> [a]
:
   (Name
"lt",     Char
'<') forall a. a -> [a] -> [a]
:
   (Name
"gt",     Char
'>') forall a. a -> [a] -> [a]
:
   []