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 =
   (Int -> Char) -> Exceptional Name Int -> Exceptional Name Char
forall a b. (a -> b) -> Exceptional Name a -> Exceptional Name b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Char
Char.chr (Exceptional Name Int -> Exceptional Name Char)
-> Exceptional Name Int -> Exceptional Name Char
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 too many 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
""  -> Name -> Exceptional Name Int
forall e a. e -> Exceptional e a
throw Name
"empty number string"
      Name
"0" -> Int -> Exceptional Name Int
forall a. a -> Exceptional Name a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
      Name
_ ->
         let m :: a -> Char -> Update Name Int
m a
pos Char
digit =
               (Int -> Exceptional Name Int) -> Update Name Int
forall e a. (a -> Exceptional e a) -> Update e a
Update ((Int -> Exceptional Name Int) -> Update Name Int)
-> (Int -> Exceptional Name Int) -> Update Name Int
forall a b. (a -> b) -> a -> b
$ \Int
mostSig ->
                  let n :: Int
n = Int
mostSigInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
Char.digitToInt Char
digit
                  in  Name -> Bool -> Exceptional Name ()
forall e. e -> Bool -> Exceptional e ()
assert (Name
"invalid character "Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++Char -> Name
forall a. Show a => a -> Name
show Char
digit)
                         (Char -> Bool
validChar Char
digit) Exceptional Name () -> Exceptional Name () -> Exceptional Name ()
forall a b.
Exceptional Name a -> Exceptional Name b -> Exceptional Name b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                      Name -> Bool -> Exceptional Name ()
forall e. e -> Bool -> Exceptional e ()
assert Name
"too many leading zeros forbidden in order to prevent denial of service"
                         (Bool -> Bool
not (a
posa -> a -> Bool
forall a. Ord a => a -> a -> Bool
>=a
8 Bool -> Bool -> Bool
&& Char
digitChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'0')) Exceptional Name () -> Exceptional Name () -> Exceptional Name ()
forall a b.
Exceptional Name a -> Exceptional Name b -> Exceptional Name b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                      Name -> Bool -> Exceptional Name ()
forall e. e -> Bool -> Exceptional e ()
assert Name
"number too big"
                         (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Char -> Int
Char.ord Char
forall a. Bounded a => a
maxBound) Exceptional Name () -> Exceptional Name Int -> Exceptional Name Int
forall a b.
Exceptional Name a -> Exceptional Name b -> Exceptional Name b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                      Int -> Exceptional Name Int
forall a. a -> Exceptional Name a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
         in  Update Name Int -> Int -> Exceptional Name Int
forall e a. Update e a -> a -> Exceptional e a
evalUpdate ([Update Name Int] -> Update Name Int
forall a. Monoid a => [a] -> a
mconcat ([Update Name Int] -> Update Name Int)
-> [Update Name Int] -> Update Name Int
forall a b. (a -> b) -> a -> b
$ (Int -> Char -> Update Name Int)
-> [Int] -> Name -> [Update Name Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Char -> Update Name Int
forall {a}. (Ord a, Num a) => a -> Char -> Update Name Int
m [(Int
0::Int)..] 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 = (a -> Exceptional e a) -> Update e a
forall e a. (a -> Exceptional e a) -> Update e a
Update (a -> Exceptional e a
y (a -> Exceptional e a)
-> (a -> Exceptional e a) -> a -> Exceptional e a
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 = (a -> Exceptional e a) -> Update e a
forall e a. (a -> Exceptional e a) -> Update e a
Update a -> Exceptional e a
forall a. a -> Exceptional e a
forall (m :: * -> *) a. Monad m => a -> m a
return
   mappend :: Update e a -> Update e a -> Update e a
mappend = Update e a -> Update e a -> Update e a
forall a. Semigroup a => a -> a -> a
(<>)



type Name = String

mapNameToChar :: Map.Map Name Char
mapNameToChar :: Map Name Char
mapNameToChar =
   [(Name, Char)] -> Map Name Char
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 =
   [(Char, Name)] -> Map Char Name
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Char, Name)] -> Map Char Name)
-> [(Char, Name)] -> Map Char Name
forall a b. (a -> b) -> a -> b
$ ((Name, Char) -> (Char, Name)) -> [(Name, Char)] -> [(Char, Name)]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Char) -> (Char, Name)
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
'\'') (Name, Char) -> [(Name, Char)] -> [(Name, 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
'"') (Name, Char) -> [(Name, Char)] -> [(Name, Char)]
forall a. a -> [a] -> [a]
:
   (Name
"amp",    Char
'&') (Name, Char) -> [(Name, Char)] -> [(Name, Char)]
forall a. a -> [a] -> [a]
:
   (Name
"lt",     Char
'<') (Name, Char) -> [(Name, Char)] -> [(Name, Char)]
forall a. a -> [a] -> [a]
:
   (Name
"gt",     Char
'>') (Name, Char) -> [(Name, Char)] -> [(Name, Char)]
forall a. a -> [a] -> [a]
:
   []