module Text.XML.DOM.Parser.Class
(
FromDom(..)
, proxyFromDom
, elementFromDom
, unionFromDom
, textFromDom
, stringFromDom
, charFromDom
, intFromDom
, integerFromDom
, doubleFromDom
, fixedFromDom
, boolFromDom
, unitFromDom
, voidFromDom
) where
import Control.Applicative
import Control.Lens
import Data.Fixed
import Data.OpenUnion
import Data.Text (Text)
import qualified Data.Text as T
import Data.Typeable
import Data.Void
import Text.Shakespeare.Text (st)
import Text.XML
import Text.XML.DOM.Parser.Combinators
import Text.XML.DOM.Parser.Types
import TypeFun.Data.List hiding (Union)
proxyFromDom
:: forall proxy m a
. (FromDom a, Monad m)
=> proxy a
-> DomParserT Identity m a
proxyFromDom _ = fromDom
class FromDom a where
fromDom :: (Monad m) => DomParserT Identity m a
instance FromDom () where
fromDom = unitFromDom
instance FromDom Void where
fromDom = voidFromDom
instance FromDom Text where
fromDom = textFromDom
instance FromDom String where
fromDom = stringFromDom
instance FromDom Char where
fromDom = charFromDom
instance FromDom Int where
fromDom = intFromDom
instance FromDom Integer where
fromDom = integerFromDom
instance FromDom Double where
fromDom = doubleFromDom
instance (HasResolution a, Typeable a) => FromDom (Fixed a) where
fromDom = fixedFromDom
instance FromDom Bool where
fromDom = boolFromDom
instance FromDom (Union '[]) where
fromDom = empty
instance ( Typeable a, FromDom a, FromDom (Union as)
, SubList as (a ': as) )
=> FromDom (Union (a ': as)) where
fromDom = (liftUnion <$> (proxyFromDom (Proxy :: Proxy a)))
<|> (reUnion <$> (proxyFromDom (Proxy :: Proxy (Union as))))
instance FromDom Element where
fromDom = elementFromDom
elementFromDom :: (Monad m) => DomParserT Identity m Element
elementFromDom = view $ pdElements . to runIdentity
unionFromDom
:: (Monad m, FromDom (Union as))
=> proxy as
-> DomParserT Identity m (Union as)
unionFromDom _ = fromDom
textFromDom :: (Monad m) => DomParserT Identity m Text
textFromDom = parseContent pure
stringFromDom :: (Monad m) => DomParserT Identity m String
stringFromDom = parseContent $ pure . T.unpack
charFromDom :: (Monad m) => DomParserT Identity m Char
charFromDom = parseContent $ \t -> case T.unpack $ T.strip t of
[c] -> pure c
_ -> throwParserError $ PEWrongFormat
"Should have exactly one non-blank character"
intFromDom :: (Monad m) => DomParserT Identity m Int
intFromDom = parseContent readContent
integerFromDom :: (Monad m) => DomParserT Identity m Integer
integerFromDom = parseContent readContent
doubleFromDom :: (Monad m) => DomParserT Identity m Double
doubleFromDom = parseContent readContent
fixedFromDom
:: (Monad m, Typeable a, HasResolution a)
=> DomParserT Identity m (Fixed a)
fixedFromDom = parseContent readContent
boolFromDom :: (Monad m) => DomParserT Identity m Bool
boolFromDom = parseContent $ \t ->
let
lowt = T.toLower $ T.strip t
tvals = ["y", "yes", "t", "true", "1"]
fvals = ["n", "no", "f", "false", "0"]
in if | lowt `elem` tvals -> return True
| lowt `elem` fvals -> return False
| otherwise ->
let msg = [st|Could not read "#{t}" as Bool|]
in throwParserError $ PEWrongFormat msg
unitFromDom :: (Monad m) => DomParserT Identity m ()
unitFromDom = pure ()
voidFromDom :: (Monad m) => DomParserT Identity m Void
voidFromDom = empty