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.String
import Data.Text as T
import GHC.Generics (Generic)
import Text.XML
import Text.XML.Lens
data ElemMatcher = ElemMatcher
{ _emMatch :: Element -> Bool
, _emShow :: Text
}
makeLenses ''ElemMatcher
instance IsString ElemMatcher where
fromString = matchElemName . fromString
instance Show ElemMatcher where
show = T.unpack . _emShow
matchElemName :: NameMatcher -> ElemMatcher
matchElemName (NameMatcher matchName showName) = ElemMatcher
{ _emMatch = views name matchName
, _emShow = showName
}
elMatch :: ElemMatcher -> Traversal' Element Element
elMatch (ElemMatcher match _) = filtered match
data NameMatcher = NameMatcher
{ _nmMatch :: Name -> Bool
, _nmShow :: Text
}
makeLenses ''NameMatcher
instance IsString NameMatcher where
fromString = matchCILocalName . T.pack
instance Show NameMatcher where
show = T.unpack . _nmShow
matchLocalName :: Text -> NameMatcher
matchLocalName tname = NameMatcher
{ _nmMatch = \n -> nameLocalName n == tname
, _nmShow = tname
}
matchCILocalName :: Text -> NameMatcher
matchCILocalName tname = NameMatcher
{ _nmMatch = \n -> CI.mk (nameLocalName n) == CI.mk tname
, _nmShow = tname
}
matchName :: Name -> NameMatcher
matchName n = NameMatcher
{ _nmMatch = (== n)
, _nmShow = nameLocalName n
}
newtype DomPath = DomPath
{ unDomPath :: [Text]
} deriving (Eq, Ord, Show, Monoid)
data ParserError
= PENotFound
{ _pePath :: DomPath
}
| PEAttributeNotFound
{ _peAttributeName :: NameMatcher
, _pePath :: DomPath
}
| PEAttributeWrongFormat
{ _peAttributeName :: NameMatcher
, _peDetails :: Text
, _pePath :: DomPath
}
| PEContentNotFound
{ _pePath :: DomPath
}
| PEContentWrongFormat
{ _peDetails :: Text
, _pePath :: DomPath
}
| PEOther
{ _peDetails :: Text
, _pePath :: DomPath
} deriving (Show, Generic)
makeLenses ''ParserError
instance Exception ParserError
newtype ParserErrors = ParserErrors
{ unParserErrors :: [ParserError]
} deriving (Show, Monoid, Generic)
makePrisms ''ParserErrors
instance Exception ParserErrors
data ParserData f = ParserData
{ _pdElements :: f Element
, _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 doc par =
let
pd = ParserData
{ _pdElements = doc ^. root . to pure
, _pdPath = DomPath [doc ^. root . name . to nameLocalName]
}
in runExceptT $ runReaderT par pd
runDomParser
:: Document
-> DomParser Identity a
-> Either ParserErrors a
runDomParser doc par = runIdentity $ runDomParserT doc par
throwParserError
:: (MonadError ParserErrors m, MonadReader (ParserData f) m)
=> (DomPath -> ParserError)
-> m a
throwParserError mkerr = do
path <- view pdPath
throwError $ ParserErrors $ [mkerr path]