module Text.XML.DOM.Parser.Types
  (-- * Element matching
    ElemMatcher(..)
  , emMatch
  , emShow
  , matchElemName
  , elMatch
    -- * Name matching
  , NameMatcher(..)
  , nmMatch
  , nmShow
  , matchName
  , matchLocalName
  , matchCILocalName
    -- * Parser internals
  , DomPath(..)
  , ParserError(..)
  , pePath
  , peDetails
  , peAttributeName
  , ParserErrors(..)
  , _ParserErrors
  , ParserData(..)
  , pdElements
  , pdPath
  , DomParserT
  , DomParser
  , runDomParserT
  , runDomParser
    -- * Auxiliary
  , 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

-- | Arbitrary element matcher
--
-- @since 2.0.0
data ElemMatcher = ElemMatcher
  { ElemMatcher -> Element -> Bool
_emMatch :: Element -> Bool
  , ElemMatcher -> Text
_emShow  :: Text
    -- ^ Field for 'Show' instance and bulding usefull errors
  }

makeLenses ''ElemMatcher

-- | Instance using instance of 'NameMatcher'
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

-- | Match element by name
--
-- @since 2.0.0
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
  }

-- | Match over elements
--
-- @since 2.0.0
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

-- | Arbitrary name matcher. Match name any way you want, but
-- considered to be used as comparator with some name with some rules
--
-- @since 2.0.0
data NameMatcher = NameMatcher
  { NameMatcher -> Name -> Bool
_nmMatch :: Name -> Bool
    -- ^ Name matching function, usually should be simple comparsion
    -- function takin in account only local name or other components
    -- of 'Name'
  , NameMatcher -> Text
_nmShow :: Text
    -- ^ Field for 'Show' instance and bulding usefull errors
  }

-- | Instance use 'matchCILocalName' as most general and liberal
-- matching strategy (while XML is often malformed).
--
-- @since 2.0.0
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

-- | Makes matcher which matches only local part of name igoring
-- namespace and prefix. Local name matching is case sensitive.
--
-- @since 2.0.0
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
  }

-- | Makes matcher which matches only local part of name igoring
-- namespace and prefix. Local name matching is case insensitive. This
-- is the most common case.
--
-- @since 2.0.0
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

-- | Makes matcher which match name by 'Eq' with given
--
-- @since 2.0.0
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
  }

-- | Path some element should be found at. Path starts from the root
-- element of the document. Errors are much more usefull with path.
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)

-- | DOM parser error description.
data ParserError
  -- | Tag not found which should be.
  = PENotFound
    { ParserError -> DomPath
_pePath :: DomPath
      -- ^ Path of element error occured in
    }

  -- | Expected attribute but not found
  --
  -- @since 1.0.0
  | PEAttributeNotFound
    { ParserError -> NameMatcher
_peAttributeName :: NameMatcher
    , _pePath          :: DomPath
    }

  -- | Could not parse attribute
  --
  -- @since 1.0.0
  | PEAttributeWrongFormat
    { _peAttributeName :: NameMatcher
    , ParserError -> Text
_peDetails       :: Text
    , _pePath          :: DomPath
    }

  -- | Node should have text content, but it does not.
  | PEContentNotFound
    { _pePath :: DomPath
    }

  -- | Tag contents has wrong format, (could not read text to value)
  | PEContentWrongFormat
    { _peDetails :: Text
    , _pePath    :: DomPath
    }

  -- | Some other error
  | 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


{- | Parser scope.

Functor argument is usually @Identity@ or @[]@.

If functor is @Identity@ then parser expects exactly ONE current element. This
is common behavior for content parsers, or parsers expecting strict XML
structure.

If functor is @[]@ then parser expects arbitrary current elements count. This is
the case when you use combinators 'divePath' or 'diveElem' (posible other
variants of similar combinators). This kind of combinators performs search for
elements somewhere in descendants and result have arbitrary length in common
case.
-}

data ParserData f = ParserData
    { forall (f :: * -> *). ParserData f -> f Element
_pdElements :: f Element
      -- ^ Current element(s). Functor is intended to be either @Identity@ or
      -- @[]@
    , forall (f :: * -> *). ParserData f -> DomPath
_pdPath     :: DomPath
      -- ^ Path for error reporting
    }

makeLenses ''ParserData

type DomParserT f m = ReaderT (ParserData f) (ExceptT ParserErrors m)
type DomParser f = DomParserT f Identity

-- | Run parser on root element of Document.
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]