module Text.XML.DOM.Parser.Types
(
ElemMatcher(..)
, emMatch
, emShow
, matchElemName
, elMatch
, NameMatcher(..)
, nmMatch
, nmShow
, matchName
, matchLocalName
, matchCILocalName
, DomPath(..)
, ParserError(..)
, pePath
, peDetails
, peAttributeName
, ParserErrors(..)
, _ParserErrors
, ParserData(..)
, pdElements
, pdPath
, DomParserT
, DomParser
, runDomParserT
, runDomParser
, throwParserError
) where
import Control.Exception
import Control.Lens
import Control.Monad.Except
import Control.Monad.Reader
import Data.CaseInsensitive as CI
import Data.Semigroup
import Data.String
import Data.Text as T
import GHC.Generics (Generic)
import Text.XML
import Text.XML.Lens
data ElemMatcher = ElemMatcher
{ ElemMatcher -> Element -> Bool
_emMatch :: Element -> Bool
, ElemMatcher -> Text
_emShow :: Text
}
makeLenses ''ElemMatcher
instance IsString ElemMatcher where
fromString :: String -> ElemMatcher
fromString = NameMatcher -> ElemMatcher
matchElemName (NameMatcher -> ElemMatcher)
-> (String -> NameMatcher) -> String -> ElemMatcher
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> NameMatcher
forall a. IsString a => String -> a
fromString
instance Show ElemMatcher where
show :: ElemMatcher -> String
show = Text -> String
T.unpack (Text -> String) -> (ElemMatcher -> Text) -> ElemMatcher -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElemMatcher -> Text
_emShow
matchElemName :: NameMatcher -> ElemMatcher
matchElemName :: NameMatcher -> ElemMatcher
matchElemName (NameMatcher Name -> Bool
matchName Text
showName) = ElemMatcher
{ _emMatch :: Element -> Bool
_emMatch = LensLike' (Const Bool) Element Name
-> (Name -> Bool) -> Element -> Bool
forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views LensLike' (Const Bool) Element Name
Lens' Element Name
name Name -> Bool
matchName
, _emShow :: Text
_emShow = Text
showName
}
elMatch :: ElemMatcher -> Traversal' Element Element
elMatch :: ElemMatcher -> Traversal' Element Element
elMatch (ElemMatcher Element -> Bool
match Text
_) = (Element -> Bool) -> (Element -> f Element) -> Element -> f Element
forall (p :: * -> * -> *) (f :: * -> *) a.
(Choice p, Applicative f) =>
(a -> Bool) -> Optic' p f a a
filtered Element -> Bool
match
data NameMatcher = NameMatcher
{ NameMatcher -> Name -> Bool
_nmMatch :: Name -> Bool
, NameMatcher -> Text
_nmShow :: Text
}
instance IsString NameMatcher where
fromString :: String -> NameMatcher
fromString = Text -> NameMatcher
matchCILocalName (Text -> NameMatcher) -> (String -> Text) -> String -> NameMatcher
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
instance Show NameMatcher where
show :: NameMatcher -> String
show = Text -> String
T.unpack (Text -> String) -> (NameMatcher -> Text) -> NameMatcher -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameMatcher -> Text
_nmShow
matchLocalName :: Text -> NameMatcher
matchLocalName :: Text -> NameMatcher
matchLocalName Text
tname = NameMatcher
{ _nmMatch :: Name -> Bool
_nmMatch = \Name
n -> Name -> Text
nameLocalName Name
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
tname
, _nmShow :: Text
_nmShow = Text
tname
}
matchCILocalName :: Text -> NameMatcher
matchCILocalName :: Text -> NameMatcher
matchCILocalName Text
tname = NameMatcher
{ _nmMatch :: Name -> Bool
_nmMatch = \Name
n -> Text -> CI Text
forall s. FoldCase s => s -> CI s
CI.mk (Name -> Text
nameLocalName Name
n) CI Text -> CI Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> CI Text
forall s. FoldCase s => s -> CI s
CI.mk Text
tname
, _nmShow :: Text
_nmShow = Text
tname
}
makeLenses ''NameMatcher
matchName :: Name -> NameMatcher
matchName :: Name -> NameMatcher
matchName Name
n = NameMatcher
{ _nmMatch :: Name -> Bool
_nmMatch = (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n)
, _nmShow :: Text
_nmShow = Name -> Text
nameLocalName Name
n
}
newtype DomPath = DomPath
{ DomPath -> [Text]
unDomPath :: [Text]
} deriving (DomPath -> DomPath -> Bool
(DomPath -> DomPath -> Bool)
-> (DomPath -> DomPath -> Bool) -> Eq DomPath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DomPath -> DomPath -> Bool
== :: DomPath -> DomPath -> Bool
$c/= :: DomPath -> DomPath -> Bool
/= :: DomPath -> DomPath -> Bool
Eq, Eq DomPath
Eq DomPath =>
(DomPath -> DomPath -> Ordering)
-> (DomPath -> DomPath -> Bool)
-> (DomPath -> DomPath -> Bool)
-> (DomPath -> DomPath -> Bool)
-> (DomPath -> DomPath -> Bool)
-> (DomPath -> DomPath -> DomPath)
-> (DomPath -> DomPath -> DomPath)
-> Ord DomPath
DomPath -> DomPath -> Bool
DomPath -> DomPath -> Ordering
DomPath -> DomPath -> DomPath
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DomPath -> DomPath -> Ordering
compare :: DomPath -> DomPath -> Ordering
$c< :: DomPath -> DomPath -> Bool
< :: DomPath -> DomPath -> Bool
$c<= :: DomPath -> DomPath -> Bool
<= :: DomPath -> DomPath -> Bool
$c> :: DomPath -> DomPath -> Bool
> :: DomPath -> DomPath -> Bool
$c>= :: DomPath -> DomPath -> Bool
>= :: DomPath -> DomPath -> Bool
$cmax :: DomPath -> DomPath -> DomPath
max :: DomPath -> DomPath -> DomPath
$cmin :: DomPath -> DomPath -> DomPath
min :: DomPath -> DomPath -> DomPath
Ord, Int -> DomPath -> ShowS
[DomPath] -> ShowS
DomPath -> String
(Int -> DomPath -> ShowS)
-> (DomPath -> String) -> ([DomPath] -> ShowS) -> Show DomPath
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DomPath -> ShowS
showsPrec :: Int -> DomPath -> ShowS
$cshow :: DomPath -> String
show :: DomPath -> String
$cshowList :: [DomPath] -> ShowS
showList :: [DomPath] -> ShowS
Show, NonEmpty DomPath -> DomPath
DomPath -> DomPath -> DomPath
(DomPath -> DomPath -> DomPath)
-> (NonEmpty DomPath -> DomPath)
-> (forall b. Integral b => b -> DomPath -> DomPath)
-> Semigroup DomPath
forall b. Integral b => b -> DomPath -> DomPath
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: DomPath -> DomPath -> DomPath
<> :: DomPath -> DomPath -> DomPath
$csconcat :: NonEmpty DomPath -> DomPath
sconcat :: NonEmpty DomPath -> DomPath
$cstimes :: forall b. Integral b => b -> DomPath -> DomPath
stimes :: forall b. Integral b => b -> DomPath -> DomPath
Semigroup, Semigroup DomPath
DomPath
Semigroup DomPath =>
DomPath
-> (DomPath -> DomPath -> DomPath)
-> ([DomPath] -> DomPath)
-> Monoid DomPath
[DomPath] -> DomPath
DomPath -> DomPath -> DomPath
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: DomPath
mempty :: DomPath
$cmappend :: DomPath -> DomPath -> DomPath
mappend :: DomPath -> DomPath -> DomPath
$cmconcat :: [DomPath] -> DomPath
mconcat :: [DomPath] -> DomPath
Monoid)
data ParserError
= PENotFound
{ ParserError -> DomPath
_pePath :: DomPath
}
| PEAttributeNotFound
{ ParserError -> NameMatcher
_peAttributeName :: NameMatcher
, _pePath :: DomPath
}
| PEAttributeWrongFormat
{ _peAttributeName :: NameMatcher
, ParserError -> Text
_peDetails :: Text
, _pePath :: DomPath
}
| PEContentNotFound
{ _pePath :: DomPath
}
| PEContentWrongFormat
{ _peDetails :: Text
, _pePath :: DomPath
}
| PEOther
{ _peDetails :: Text
, _pePath :: DomPath
} deriving (Int -> ParserError -> ShowS
[ParserError] -> ShowS
ParserError -> String
(Int -> ParserError -> ShowS)
-> (ParserError -> String)
-> ([ParserError] -> ShowS)
-> Show ParserError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParserError -> ShowS
showsPrec :: Int -> ParserError -> ShowS
$cshow :: ParserError -> String
show :: ParserError -> String
$cshowList :: [ParserError] -> ShowS
showList :: [ParserError] -> ShowS
Show, (forall x. ParserError -> Rep ParserError x)
-> (forall x. Rep ParserError x -> ParserError)
-> Generic ParserError
forall x. Rep ParserError x -> ParserError
forall x. ParserError -> Rep ParserError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ParserError -> Rep ParserError x
from :: forall x. ParserError -> Rep ParserError x
$cto :: forall x. Rep ParserError x -> ParserError
to :: forall x. Rep ParserError x -> ParserError
Generic)
makeLenses ''ParserError
instance Exception ParserError
newtype ParserErrors = ParserErrors
{ ParserErrors -> [ParserError]
unParserErrors :: [ParserError]
} deriving (Int -> ParserErrors -> ShowS
[ParserErrors] -> ShowS
ParserErrors -> String
(Int -> ParserErrors -> ShowS)
-> (ParserErrors -> String)
-> ([ParserErrors] -> ShowS)
-> Show ParserErrors
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParserErrors -> ShowS
showsPrec :: Int -> ParserErrors -> ShowS
$cshow :: ParserErrors -> String
show :: ParserErrors -> String
$cshowList :: [ParserErrors] -> ShowS
showList :: [ParserErrors] -> ShowS
Show, NonEmpty ParserErrors -> ParserErrors
ParserErrors -> ParserErrors -> ParserErrors
(ParserErrors -> ParserErrors -> ParserErrors)
-> (NonEmpty ParserErrors -> ParserErrors)
-> (forall b. Integral b => b -> ParserErrors -> ParserErrors)
-> Semigroup ParserErrors
forall b. Integral b => b -> ParserErrors -> ParserErrors
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: ParserErrors -> ParserErrors -> ParserErrors
<> :: ParserErrors -> ParserErrors -> ParserErrors
$csconcat :: NonEmpty ParserErrors -> ParserErrors
sconcat :: NonEmpty ParserErrors -> ParserErrors
$cstimes :: forall b. Integral b => b -> ParserErrors -> ParserErrors
stimes :: forall b. Integral b => b -> ParserErrors -> ParserErrors
Semigroup, Semigroup ParserErrors
ParserErrors
Semigroup ParserErrors =>
ParserErrors
-> (ParserErrors -> ParserErrors -> ParserErrors)
-> ([ParserErrors] -> ParserErrors)
-> Monoid ParserErrors
[ParserErrors] -> ParserErrors
ParserErrors -> ParserErrors -> ParserErrors
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: ParserErrors
mempty :: ParserErrors
$cmappend :: ParserErrors -> ParserErrors -> ParserErrors
mappend :: ParserErrors -> ParserErrors -> ParserErrors
$cmconcat :: [ParserErrors] -> ParserErrors
mconcat :: [ParserErrors] -> ParserErrors
Monoid, (forall x. ParserErrors -> Rep ParserErrors x)
-> (forall x. Rep ParserErrors x -> ParserErrors)
-> Generic ParserErrors
forall x. Rep ParserErrors x -> ParserErrors
forall x. ParserErrors -> Rep ParserErrors x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ParserErrors -> Rep ParserErrors x
from :: forall x. ParserErrors -> Rep ParserErrors x
$cto :: forall x. Rep ParserErrors x -> ParserErrors
to :: forall x. Rep ParserErrors x -> ParserErrors
Generic)
makePrisms ''ParserErrors
instance Exception ParserErrors
data ParserData f = ParserData
{ forall (f :: * -> *). ParserData f -> f Element
_pdElements :: f Element
, forall (f :: * -> *). ParserData f -> DomPath
_pdPath :: DomPath
}
makeLenses ''ParserData
type DomParserT f m = ReaderT (ParserData f) (ExceptT ParserErrors m)
type DomParser f = DomParserT f Identity
runDomParserT
:: (Monad m)
=> Document
-> DomParserT Identity m a
-> m (Either ParserErrors a)
runDomParserT :: forall (m :: * -> *) a.
Monad m =>
Document -> DomParserT Identity m a -> m (Either ParserErrors a)
runDomParserT Document
doc DomParserT Identity m a
par =
let
pd :: ParserData Identity
pd = ParserData
{ _pdElements :: Identity Element
_pdElements = Document
doc Document
-> Getting (Identity Element) Document (Identity Element)
-> Identity Element
forall s a. s -> Getting a s a -> a
^. (Element -> Const (Identity Element) Element)
-> Document -> Const (Identity Element) Document
Lens' Document Element
root ((Element -> Const (Identity Element) Element)
-> Document -> Const (Identity Element) Document)
-> ((Identity Element
-> Const (Identity Element) (Identity Element))
-> Element -> Const (Identity Element) Element)
-> Getting (Identity Element) Document (Identity Element)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Element -> Identity Element)
-> (Identity Element
-> Const (Identity Element) (Identity Element))
-> Element
-> Const (Identity Element) Element
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Element -> Identity Element
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
, _pdPath :: DomPath
_pdPath = [Text] -> DomPath
DomPath [Document
doc Document -> Getting Text Document Text -> Text
forall s a. s -> Getting a s a -> a
^. (Element -> Const Text Element) -> Document -> Const Text Document
Lens' Document Element
root ((Element -> Const Text Element)
-> Document -> Const Text Document)
-> ((Text -> Const Text Text) -> Element -> Const Text Element)
-> Getting Text Document Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Const Text Name) -> Element -> Const Text Element
Lens' Element Name
name ((Name -> Const Text Name) -> Element -> Const Text Element)
-> ((Text -> Const Text Text) -> Name -> Const Text Name)
-> (Text -> Const Text Text)
-> Element
-> Const Text Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Text)
-> (Text -> Const Text Text) -> Name -> Const Text Name
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Name -> Text
nameLocalName]
}
in ExceptT ParserErrors m a -> m (Either ParserErrors a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ParserErrors m a -> m (Either ParserErrors a))
-> ExceptT ParserErrors m a -> m (Either ParserErrors a)
forall a b. (a -> b) -> a -> b
$ DomParserT Identity m a
-> ParserData Identity -> ExceptT ParserErrors m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT DomParserT Identity m a
par ParserData Identity
pd
runDomParser
:: Document
-> DomParser Identity a
-> Either ParserErrors a
runDomParser :: forall a. Document -> DomParser Identity a -> Either ParserErrors a
runDomParser Document
doc DomParser Identity a
par = Identity (Either ParserErrors a) -> Either ParserErrors a
forall a. Identity a -> a
runIdentity (Identity (Either ParserErrors a) -> Either ParserErrors a)
-> Identity (Either ParserErrors a) -> Either ParserErrors a
forall a b. (a -> b) -> a -> b
$ Document
-> DomParser Identity a -> Identity (Either ParserErrors a)
forall (m :: * -> *) a.
Monad m =>
Document -> DomParserT Identity m a -> m (Either ParserErrors a)
runDomParserT Document
doc DomParser Identity a
par
throwParserError
:: (MonadError ParserErrors m, MonadReader (ParserData f) m)
=> (DomPath -> ParserError)
-> m a
throwParserError :: forall (m :: * -> *) (f :: * -> *) a.
(MonadError ParserErrors m, MonadReader (ParserData f) m) =>
(DomPath -> ParserError) -> m a
throwParserError DomPath -> ParserError
mkerr = do
DomPath
path <- Getting DomPath (ParserData f) DomPath -> m DomPath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting DomPath (ParserData f) DomPath
forall (f :: * -> *) (f :: * -> *).
Functor f =>
(DomPath -> f DomPath) -> ParserData f -> f (ParserData f)
pdPath
ParserErrors -> m a
forall a. ParserErrors -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ParserErrors -> m a) -> ParserErrors -> m a
forall a b. (a -> b) -> a -> b
$ [ParserError] -> ParserErrors
ParserErrors ([ParserError] -> ParserErrors) -> [ParserError] -> ParserErrors
forall a b. (a -> b) -> a -> b
$ [DomPath -> ParserError
mkerr DomPath
path]