dom-parser 1.0.0 → 2.0.0

raw patch · 12 files changed

+715/−399 lines, 12 filesdep +case-insensitivedep +scientificdep ~textPVP ok

version bump matches the API change (PVP)

Dependencies added: case-insensitive, scientific

Dependency ranges changed: text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +17/−1
• dom-parser.cabal +9/−3
• src/Text/XML/DOM/Parser.hs +10/−2
• src/Text/XML/DOM/Parser/Attributes.hs +64/−0
• src/Text/XML/DOM/Parser/Buildable.hs +26/−0
• src/Text/XML/DOM/Parser/Class.hs +0/−154
• src/Text/XML/DOM/Parser/Combinators.hs +55/−167
• src/Text/XML/DOM/Parser/Content.hs +128/−0
• src/Text/XML/DOM/Parser/FromAttribute.hs +112/−0
• src/Text/XML/DOM/Parser/FromDom.hs +140/−0
• src/Text/XML/DOM/Parser/Types.hs +144/−62
• test/Main.hs +10/−10

@@ -1,10 +1,26 @@ # CHANGELOG +## 2.0.0++### Added++* `NameMatcher` and `ElemMatcher` as more flexible mechanisms for+  matching names and elements instead of just matching by name.+* Class `FromAttribute` and some default instances++### Changed++* `DomTraversable` renamed to `Buildable`+* Combinators use `NameMatcher` and `ElemMatcher`+* Documentation improved+ ## 1.0.0+ * Added support for parsing attributes * Changed public interface for 'parseContent'-* Added usefull functions+* Added useful functions * Dropped unnecessary dependency from shakespeare  ## 0.1.0+ * Public release

@@ -1,5 +1,5 @@ name:                dom-parser-version:             1.0.0+version:             2.0.0 synopsis:            Simple monadic DOM parser license:             MIT license-file:        LICENSE@@ -44,10 +44,12 @@                      , TypeOperators                      , UndecidableInstances   build-depends:       base >= 4.7 && < 5+                     , case-insensitive                      , containers                      , lens                      , mtl-                     , open-union+                     , open-union >= 0.2+                     , scientific                      , semigroups                      , text                      , transformers@@ -55,8 +57,12 @@                      , xml-conduit                      , xml-lens   exposed-modules: Text.XML.DOM.Parser-                 , Text.XML.DOM.Parser.Class+                 , Text.XML.DOM.Parser.Attributes+                 , Text.XML.DOM.Parser.Buildable                  , Text.XML.DOM.Parser.Combinators+                 , Text.XML.DOM.Parser.Content+                 , Text.XML.DOM.Parser.FromAttribute+                 , Text.XML.DOM.Parser.FromDom                  , Text.XML.DOM.Parser.Types  test-suite test

@@ -1,9 +1,17 @@ module Text.XML.DOM.Parser-  ( module Text.XML.DOM.Parser.Class+  ( module Text.XML.DOM.Parser.Attributes+  , module Text.XML.DOM.Parser.Buildable   , module Text.XML.DOM.Parser.Combinators+  , module Text.XML.DOM.Parser.Content+  , module Text.XML.DOM.Parser.FromAttribute+  , module Text.XML.DOM.Parser.FromDom   , module Text.XML.DOM.Parser.Types   ) where -import Text.XML.DOM.Parser.Class+import Text.XML.DOM.Parser.Attributes+import Text.XML.DOM.Parser.Buildable import Text.XML.DOM.Parser.Combinators+import Text.XML.DOM.Parser.Content+import Text.XML.DOM.Parser.FromAttribute+import Text.XML.DOM.Parser.FromDom import Text.XML.DOM.Parser.Types

@@ -0,0 +1,64 @@+module Text.XML.DOM.Parser.Attributes+  ( parseAttribute+  , parseAttributeMaybe+  , getCurrentAttributes+  , getCurrentAttribute+  ) where++import Control.Lens+import Data.Map.Strict as M+import Data.Text as T+import Text.XML.DOM.Parser.Types+import Text.XML.Lens++-- | Parses attribute with given name, throws error if attribute is not found.+--+-- @since 1.0.0+parseAttribute+  :: (Monad m)+  => NameMatcher+     -- ^ Attribute name+  -> (Text -> Either Text a)+     -- ^ Attribute content parser+  -> DomParserT Identity m a+parseAttribute attrName parser =+  parseAttributeMaybe attrName parser >>= \case+    Nothing -> throwParserError $ PEAttributeNotFound attrName+    Just a  -> return a++-- | Parses attribute with given name. Returns Nothing if attribute is+-- not found.+--+-- @since 1.0.0+parseAttributeMaybe+  :: (Monad m)+  => NameMatcher+     -- ^ Attribute name+  -> (Text -> Either Text a)+     -- ^ Attribute content parser+  -> DomParserT Identity m (Maybe a)+parseAttributeMaybe attrName parser =+  getCurrentAttribute attrName >>= \case+    Nothing   -> return Nothing+    Just aval -> case parser aval of+      Left err -> throwParserError $ PEAttributeWrongFormat attrName err+      Right a  -> return $ Just a++-- | Retuns map of attributes of current element+--+-- @since 1.0.0+getCurrentAttributes+  :: (Monad m)+  => DomParserT Identity m (M.Map Name Text)+getCurrentAttributes = view $ pdElements . to runIdentity . attrs++-- | Returns element with given name or 'Nothing'+--+-- @since 1.0.0+getCurrentAttribute+  :: (Monad m)+  => NameMatcher+  -> DomParserT Identity m (Maybe Text)+getCurrentAttribute attrName+  = preview $ pdElements . to runIdentity . attrs . to M.toList+  . traversed . filtered (views _1 (attrName ^. nmMatch)) . _2

@@ -0,0 +1,26 @@+module Text.XML.DOM.Parser.Buildable+  ( Buildable(..)+  ) where++import Data.Functor.Identity+import Data.List.NonEmpty as NE+import Data.Maybe++-- | Class of traversable functors which may be constructed from list+class Traversable f => Buildable f where+  -- | If method return Nothing this means we can not build+  -- traversable from given list. In this case 'inFilteredTrav' should+  -- fail traversing.+  build :: [a] ->  Maybe (f a)++instance Buildable Identity where+  build = fmap Identity . listToMaybe++instance Buildable [] where+  build = Just++instance Buildable Maybe where+  build = Just . listToMaybe++instance Buildable NonEmpty where+  build = NE.nonEmpty

@@ -1,154 +0,0 @@-module Text.XML.DOM.Parser.Class-  ( -- * FromDom-    FromDom(..)-  , proxyFromDom-    -- * Explicit methods for convenience-  , elementFromDom-  , unionFromDom-  , textFromDom-  , stringFromDom-  , charFromDom-  , readChar-  , intFromDom-  , integerFromDom-  , doubleFromDom-  , fixedFromDom-  , boolFromDom-  , readBool-  , unitFromDom-  , voidFromDom-  ) where--import           Control.Applicative-import           Control.Lens-import           Data.Fixed-import           Data.Monoid-import           Data.OpenUnion-import           Data.Text (Text)-import qualified Data.Text as T-import           Data.Typeable-import           Data.Void-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 of types which can be parsed from single XML element.-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 :: forall m. (DomParserMonad m) => m a-  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 Right--stringFromDom :: (Monad m) => DomParserT Identity m String-stringFromDom = parseContent $ Right . T.unpack--charFromDom :: (Monad m) => DomParserT Identity m Char-charFromDom = parseContent readChar---- | Expects text to be single character------ @since 1.0.0-readChar :: Text -> Either Text Char-readChar t = case T.unpack $ T.strip t of-  [c] -> Right c-  _   -> Left "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---- | Expects content to be y, yes, t, true or 1 for True value. n, no,--- f, false or 0 for False value. Case is not significant, blank--- characters are striped.-boolFromDom :: (Monad m) => DomParserT Identity m Bool-boolFromDom = parseContent readBool---- | @since 1.0.0-readBool :: Text -> Either Text Bool-readBool 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 -> Right True-        | lowt `elem` fvals -> Right False-        | otherwise         ->-            Left $ "Could not read " <> t <> " as Bool"---- | Always successfully parses any DOM to @()@-unitFromDom :: (Monad m) => DomParserT Identity m  ()-unitFromDom = pure ()---- | Never parses successfully. It is just 'mzero'-voidFromDom :: (Monad m) => DomParserT Identity m  Void-voidFromDom = empty

@@ -2,7 +2,7 @@   ( -- * Generic combinators to traverse descendants     traverseElems   , inFilteredTrav-    -- * Using 'DomTraversable'+    -- * Using 'Buildable'   , inElemTrav   , inElem   , inElemAll@@ -15,116 +15,107 @@   , ignoreElem   , ignoreEmpty   , ignoreBlank-    -- * Getting current element's properties-  , getCurrentName-  , getCurrentContent-  , getCurrentAttributes-  , getCurrentAttribute-    -- * Current element's checks-  , checkCurrentName-    -- * Parsing element's content-  , parseContent-  , readContent-  , maybeReadContent-    -- * Parsing attributes-  , parseAttribute   ) where -import           Control.Lens-import           Control.Monad.Except-import           Control.Monad.Reader-import           Data.List.NonEmpty (NonEmpty(..))-import qualified Data.Map.Strict as M-import           Data.Monoid-import           Data.Text (Text)-import qualified Data.Text as T-import           Data.Traversable-import           Data.Typeable-import           Text.Read-import           Text.XML-import           Text.XML.DOM.Parser.Types-import           Text.XML.Lens+import Control.Lens+import Control.Monad.Reader+import Data.Foldable as F+import Data.List as L+import Data.List.NonEmpty (NonEmpty(..))+import Data.Monoid+import Data.Text as T+import Data.Traversable+import Text.XML+import Text.XML.DOM.Parser.Buildable+import Text.XML.DOM.Parser.Types+import Text.XML.Lens  --- | Generic function to traverse arbitrary inner cursors.+-- | Generic function to traverse arbitrary inner elements. traverseElems   :: (Monad m, Foldable g, Traversable f)   => ([Element] -> DomParserT g m (f (DomPath, Element)))      -- ^ Takes list of current elements and returns container with-     -- pairs of subpath (relatively to current element) and element+     -- pairs of subpath (relatively to current elements) and element      -- to run parser in   -> DomParserT Identity m a-     -- ^ Parser will be runned for each element found in traversable+     -- ^ Parser to run for each element found in traversable 'f'   -> DomParserT g m (f a) traverseElems trav parser = do   pd <- ask   inner <- trav $ pd ^.. pdElements . folded   for inner $ \(subpath, e) -> do-    let newpd = ParserData-          { _pdElements = Identity e-          , _pdPath     = pd ^. pdPath <> subpath }-    magnify (to $ const newpd) parser -- type of reader is changed, so-                                      -- local does not work+    let+      newpd = ParserData+        { _pdElements = Identity e+        , _pdPath     = pd ^. pdPath <> subpath }+    lift $ runReaderT parser newpd --- | Takes function filtering+-- | Traverses elements located in same path using filtering function inFilteredTrav-  :: (Monad m, Foldable g, DomTraversable f)+  :: (Monad m, Foldable g, Buildable f)   => ([Element] -> (DomPath, [Element]))-   -- ^ Function returning some filtered elements with path suffixes which will-   -- be appended to parser's state+  -- ^ Takes list of current elements and returns some descendants+  -- subset and path this descendants located at. Path is should be+  -- same for all descendants and required for error message   -> DomParserT Identity m a   -> DomParserT g m (f a) inFilteredTrav deeper = traverseElems trav   where     trav e = do       let (path, elems) = deeper e-      case buildDomTraversable elems of+      case build elems of         Nothing -> throwParserError $ PENotFound . (<> path)         Just tr -> return $ fmap (path,) tr +-- | Runs parser arbitrary times, depending on 'Buildable' instance of+-- 'f'. For example if 'f' becomes 'NonEmpty' then 'inElemTrav' finds+-- @one or more@ elements matched by given 'ElemMatcher' and run+-- parser in each found element, then returns @NonEmpty a@ of results. inElemTrav-  :: (Monad m, Foldable g, DomTraversable f)-  => Text+  :: (Monad m, Foldable g, Buildable f)+  => ElemMatcher                -- ^ Tag(s) matcher to traverse in   -> DomParserT Identity m a   -> DomParserT g m (f a) inElemTrav n = inFilteredTrav deeper   where-    deeper = ([n],) . toListOf (folded . nodes . folded . _Element . ell n)+    elemsFold = folded . nodes . folded . _Element . elMatch n+    deeper = (DomPath [_emShow n],) . toListOf elemsFold --- | Runs parser inside first children element with given name+-- | Runs parser inside first children element matched by macher inElem   :: (Monad m, Foldable g)-  => Text+  => ElemMatcher   -> DomParserT Identity m a   -> DomParserT g m a inElem n = fmap runIdentity . inElemTrav n  inElemAll   :: (Monad m, Foldable g)-  => Text+  => ElemMatcher   -> DomParserT Identity m a   -> DomParserT g m [a] inElemAll = inElemTrav  inElemMay   :: (Monad m, Foldable g)-  => Text+  => ElemMatcher   -> DomParserT Identity m a   -> DomParserT g m (Maybe a) inElemMay = inElemTrav  inElemNe   :: (Monad m, Foldable g)-  => Text+  => ElemMatcher   -> DomParserT Identity m a   -> DomParserT g m (NonEmpty a) inElemNe = inElemTrav  {- | Dive given parser's current tags set into the given path. The @divePath-["a", "b"]@ differs from @inElem "a" . inElem "b"@. Namely the first variant+["a", "b"]@ differs from @inElem "a" $ inElem "b"@. Namely the first variant will not fail if occured tag "a" which does not contains tag "b". This behaviour is desireable when you dont want to parse whole XML and just want-to pull tags in some path. The other difference is in traversing inner+to pull tags located in some path. The other difference is in traversing inner elements. Consider this code  @@@ -142,26 +133,31 @@ As you can see, inElem always takes first element and runs inner parser in this single element, unlike 'divePath' which runs inner parser @in all@ descendants in given path.++Note also that 'divePath' takes parser parameterized by @[]@ not by+'Identity'. This because when you dive using some path you will get a+list of found elements and all these elements will be @current@ for+parser. -}  divePath   :: forall m g a    . (Monad m, Foldable g)-  => [Text]+  => [ElemMatcher]   -> DomParserT [] m a   -> DomParserT g m a divePath path = magnify $ to modElems   where     modElems       = over pdElements (toListOf $ folded . diver)-      . over pdPath (<> path)+      . over pdPath (<> DomPath (L.map _emShow path))     diver :: Fold Element Element-    diver    = foldr (.) id $ map toDive path-    toDive n = nodes . folded . _Element . ell n+    diver    = F.foldr (.) id $ L.map toDive path+    toDive n = nodes . folded . _Element . elMatch n  diveElem   :: (Monad m, Foldable g)-  => Text+  => ElemMatcher   -> DomParserT [] m a   -> DomParserT g m a diveElem p = divePath [p]@@ -179,7 +175,7 @@   if ign then pure Nothing else Just <$> parser  -- | If current element has no children nodes does not run parser and returns--- Nothing. Otherwise runs parser inside current element. Usefull when you got+-- Nothing. Otherwise runs parser inside current element. Useful when you got -- XML with strange empty elements which must be just ignored, but `inElem` runs -- parser inside of this elements which causes to parser error. ignoreEmpty@@ -188,7 +184,7 @@   -> DomParserT Identity m (Maybe a) ignoreEmpty = ignoreElem test   where-    test e = null $ e ^. nodes+    test e = L.null $ e ^. nodes  -- | If all current elements contains blank content, or contains nothing at all -- , then returns Nothing, else runs parser.@@ -202,114 +198,6 @@       let         elems = e ^.. nodes . folded . _Element         cont = mconcat $ e ^.. nodes . folded . _Content-      in if | not $ null elems      -> False+      in if | not $ L.null elems    -> False             | T.null $ T.strip cont -> True             | otherwise             -> False---- | Returns name of current element.------ @since 1.0.0-getCurrentName :: (Monad m) => DomParserT Identity m Text-getCurrentName = view $ pdElements . to runIdentity . localName---- | If name of current tag differs from first argument throws 'PENotFound' with--- tag name replaced in last path's segment. Usefull for checking root--- document's element name.-checkCurrentName-  :: (Monad m)-  => Text-  -> DomParserT Identity m ()-checkCurrentName n = do-  cn <- getCurrentName-  unless (cn == n) $ do-    p <- view pdPath-    let pinit = if null p then [] else init p-    throwError $ ParserErrors [PENotFound $ pinit ++ [n]]-  return ()---- | Get current content. If current element contains no content or--- have inner elements then Nothing returned------ @since 1.0.0-getCurrentContent :: (Monad m) => DomParserT Identity m (Maybe Text)-getCurrentContent = do-  nds <- view $ pdElements . to runIdentity . nodes-  let-    els :: [Element]-    els = nds ^.. folded . _Element-    conts :: [Text]-    conts = nds ^.. folded . _Content-  return $ if-    | not $ null els -> Nothing-    | null conts     -> Nothing-    | otherwise      -> Just $ mconcat conts---- | Parses content inside current tag. It expects current element set--- consists of exactly ONE element. If current element does not--- contains content or have other elements as childs then throws error-parseContent-  :: (Monad m)-  => (Text -> Either Text a)-     -- ^ Content parser, return error msg if value is not parsed-  -> DomParserT Identity m a-parseContent parse = getCurrentContent >>= \case-  Nothing -> throwParserError PEContentNotFound-  Just c  -> case parse c of-    Left e  -> throwParserError $ PEWrongFormat e-    Right a -> return a---- | If reader returns 'Nothing' then resulting function returns 'Left--- "error message"'------ @since 1.0.0-maybeReadContent-  :: forall a-   . (Typeable a)-  => (Text -> Maybe a)-   -- ^ Content or attribute reader-  -> Text-   -- ^ Content or attribute value-  -> Either Text a-maybeReadContent f t = maybe (Left msg) Right $ f t-  where-    msg = "Not readable " <> n <> ": " <> t-    n = T.pack $ show $ typeRep (Proxy :: Proxy a)---- | Tries to read given text to value using 'Read'. Usefull to use--- with 'parseContent' and 'parseAttribute'-readContent-  :: (Read a, Typeable a)-  => Text-  -> Either Text a-readContent = maybeReadContent $ readMaybe . T.unpack . T.strip---- | Retuns map of attributes of current element------ @since 1.0.0-getCurrentAttributes :: (Monad m) => DomParserT Identity m (M.Map Name Text)-getCurrentAttributes = view $ pdElements . to runIdentity . attrs---- | Returns element with given name or 'Nothing'------ @since 1.0.0-getCurrentAttribute :: (Monad m) => Text -> DomParserT Identity m (Maybe Text)-getCurrentAttribute attrName'-  = preview $ pdElements . to runIdentity . attr attrName-  where-    attrName = Name attrName' Nothing Nothing---- | Parses attribute with given name, throws error if attribute is not found.------ @since 1.0.0-parseAttribute-  :: (Monad m)-  => Text-     -- ^ Attribute name-  -> (Text -> Either Text a)-     -- ^ Attribute content parser-  -> DomParserT Identity m a-parseAttribute attrName parser = getCurrentAttribute attrName >>= \case-  Nothing   -> throwParserError $ PEAttributeNotFound attrName-  Just aval -> case parser aval of-    Left err -> throwParserError $ PEAttributeWrongFormat attrName err-    Right a  -> return a

@@ -0,0 +1,128 @@+module Text.XML.DOM.Parser.Content+  (+    -- * Parsing element's content+    parseContent+    -- * Getting current element's properties+  , getCurrentName+  , getCurrentContent+  , checkCurrentName+    -- * Internal+  , maybeReadContent+  , readContent+  , readBool+  , readChar+  ) where++import Control.Lens+import Control.Monad+import Control.Monad.Except+import Data.List as L+import Data.Monoid+import Data.Text as T+import Data.Typeable+import Text.Read+import Text.XML.DOM.Parser.Types+import Text.XML.Lens+++-- | Parses content inside current tag. It expects current element set+-- consists of exactly ONE element.+parseContent+  :: (Monad m)+  => (Text -> Either Text a)+     -- ^ Content parser, return error msg if value is not parsed+  -> DomParserT Identity m a+parseContent parse = getCurrentContent >>= \case+  Nothing -> throwParserError PEContentNotFound+  Just c  -> case parse c of+    Left e  -> throwParserError $ PEContentWrongFormat e+    Right a -> return a+++-- | Returns name of current element.+--+-- @since 1.0.0+getCurrentName :: (Monad m) => DomParserT Identity m Name+getCurrentName = view $ pdElements . to runIdentity . name++-- | If name of current tag differs from first argument throws 'PENotFound' with+-- tag name replaced in last path's segment. Useful for checking root+-- document's element name.+checkCurrentName+  :: (Monad m)+  => NameMatcher+  -> DomParserT Identity m ()+checkCurrentName n = do+  cn <- getCurrentName+  unless ((n ^. nmMatch) cn) $ do+    p <- view pdPath+    let pinit = if L.null (unDomPath p) then [] else L.init $ unDomPath p+    throwError $ ParserErrors [PENotFound $ DomPath $ pinit ++ [_nmShow n]]+  return ()++-- | Get current content. If current element contains no content or+-- have inner elements then Nothing returned+--+-- @since 1.0.0+getCurrentContent :: (Monad m) => DomParserT Identity m (Maybe Text)+getCurrentContent = do+  nds <- view $ pdElements . to runIdentity . nodes+  let+    els :: [Element]+    els = nds ^.. folded . _Element+    conts :: [Text]+    conts = nds ^.. folded . _Content+  return $ if+    | not $ L.null els -> Nothing+    | L.null conts     -> Nothing+    | otherwise      -> Just $ mconcat conts++-- | If reader returns 'Nothing' then resulting function returns 'Left+-- "error message"'. 'Typeable' is used for generating usefull error+-- message.+--+-- @since 1.0.0+maybeReadContent+  :: forall a+   . (Typeable a)+  => (Text -> Maybe a)+   -- ^ Content or attribute reader+  -> Text+   -- ^ Content or attribute value+  -> Either Text a+maybeReadContent f t = maybe (Left msg) Right $ f t+  where+    msg = "Not readable " <> n <> ": " <> t+    n = T.pack $ show $ typeRep (Proxy :: Proxy a)+++-- | Tries to read given text to value using 'Read'. Useful to use+-- with 'parseContent' and 'parseAttribute'. Content is stripped+-- before reading.+readContent+  :: (Read a, Typeable a)+  => Text+  -> Either Text a+readContent = maybeReadContent $ readMaybe . T.unpack . T.strip+++-- | @since 1.0.0+readBool :: Text -> Either Text Bool+readBool 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 -> Right True+    | lowt `elem` fvals -> Right False+    | otherwise         ->+        Left $ "Could not read " <> t <> " as Bool"++-- | Expects text to be single character+--+-- @since 1.0.0+readChar :: Text -> Either Text Char+readChar t = case T.unpack $ T.strip t of+  [c] -> Right c+  _   -> Left "Should have exactly one non-blank character"

@@ -0,0 +1,112 @@+module Text.XML.DOM.Parser.FromAttribute+  ( -- * FromAttribute+    FromAttribute(..)+  , proxyFromAttribute+    -- * Explicit methods+  , textFromAttribute+  , stringFromAttribute+  , charFromAttribute+  , intFromAttribute+  , integerFromAttribute+  , doubleFromAttribute+  , fixedFromAttribute+  , boolFromAttribute+  , unitFromAttribute+  , voidFromAttribute+  , scientificFromAttribute+  ) where++import Data.Fixed+import Data.Scientific+import Data.Text as T+import Data.Typeable+import Data.Void+import Text.XML.DOM.Parser.Content++-- | Class of types which can be get from attribute value. Method+-- 'fromAttribute' is a convenient default parameter for+-- 'parseAttribute'+--+-- @since 2.0.0+class FromAttribute a where+  fromAttribute+    :: Text+    -- ^ Attribute contents to parse+    -> Either Text a+    -- ^ Either error message or result++proxyFromAttribute+  :: FromAttribute a+  => Proxy a+  -> Text+  -> Either Text a+proxyFromAttribute _ = fromAttribute++instance FromAttribute () where+  fromAttribute = unitFromAttribute++unitFromAttribute :: Text -> Either Text ()+unitFromAttribute _ = Right ()++instance FromAttribute Void where+  fromAttribute = voidFromAttribute++voidFromAttribute :: Text -> Either Text Void+voidFromAttribute _ = Left "Void has been parsed"++instance FromAttribute Text where+  fromAttribute = textFromAttribute++textFromAttribute :: Text -> Either Text Text+textFromAttribute = Right++instance FromAttribute String where+  fromAttribute = stringFromAttribute++stringFromAttribute :: Text -> Either Text String+stringFromAttribute = Right . T.unpack++instance FromAttribute Char where+  fromAttribute = charFromAttribute++charFromAttribute :: Text -> Either Text Char+charFromAttribute = readChar++instance FromAttribute Int where+  fromAttribute = intFromAttribute++intFromAttribute :: Text -> Either Text Int+intFromAttribute = readContent++instance FromAttribute Integer where+  fromAttribute = integerFromAttribute++integerFromAttribute :: Text -> Either Text Integer+integerFromAttribute = readContent++instance FromAttribute Double where+  fromAttribute = doubleFromAttribute++doubleFromAttribute :: Text -> Either Text Double+doubleFromAttribute = readContent++instance (Typeable a, HasResolution a) => FromAttribute (Fixed a) where+  fromAttribute = fixedFromAttribute++fixedFromAttribute+  :: (HasResolution a, Typeable a)+  => Text+  -> Either Text (Fixed a)+fixedFromAttribute = readContent++instance FromAttribute Bool where+  fromAttribute = boolFromAttribute++boolFromAttribute :: Text -> Either Text Bool+boolFromAttribute = readBool++instance FromAttribute Scientific where+  fromAttribute = scientificFromAttribute++scientificFromAttribute :: Text -> Either Text Scientific+scientificFromAttribute = readContent

@@ -0,0 +1,140 @@+module Text.XML.DOM.Parser.FromDom+  ( -- * FromDom+    FromDom(..)+  , proxyFromDom+    -- * Explicit methods for convenience+  , elementFromDom+  , unionFromDom+  , textFromDom+  , stringFromDom+  , charFromDom+  , intFromDom+  , integerFromDom+  , doubleFromDom+  , fixedFromDom+  , boolFromDom+  , unitFromDom+  , voidFromDom+  , scientificFromDom+  ) where++import Control.Applicative+import Control.Lens+import Data.Fixed+import Data.OpenUnion+import Data.Scientific+import Data.Text as T hiding (empty)+import Data.Typeable+import Data.Void+import Text.XML+import Text.XML.DOM.Parser.Content+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 of types which can be parsed from single XML element. The+-- method 'fromDom' is convenient default to use with 'inElem'+class FromDom a where+  fromDom :: (Monad m) => DomParserT Identity m a++instance FromDom () where+  fromDom = unitFromDom++-- | Always successfully parses any DOM to @()@+unitFromDom :: (Monad m) => DomParserT Identity m  ()+unitFromDom = pure ()++instance FromDom Void where+  fromDom = voidFromDom++-- | Never parses successfully. It is just 'empty'+voidFromDom :: (Monad m) => DomParserT Identity m  Void+voidFromDom = empty++instance FromDom Text where+  fromDom = textFromDom++textFromDom :: (Monad m) => DomParserT Identity m Text+textFromDom = parseContent Right++instance FromDom String where+  fromDom = stringFromDom++stringFromDom :: (Monad m) => DomParserT Identity m String+stringFromDom = parseContent $ Right . T.unpack++instance FromDom Char where+  fromDom = charFromDom++charFromDom :: (Monad m) => DomParserT Identity m Char+charFromDom = parseContent readChar++instance FromDom Int where+  fromDom = intFromDom++intFromDom :: (Monad m) => DomParserT Identity m Int+intFromDom = parseContent readContent++instance FromDom Integer where+  fromDom = integerFromDom++integerFromDom :: (Monad m) => DomParserT Identity m Integer+integerFromDom = parseContent readContent++instance FromDom Double where+  fromDom = doubleFromDom++doubleFromDom :: (Monad m) => DomParserT Identity m Double+doubleFromDom = parseContent readContent++instance (HasResolution a, Typeable a) => FromDom (Fixed a) where+  fromDom = fixedFromDom++fixedFromDom+  :: (Monad m, Typeable a, HasResolution a)+  => DomParserT Identity m (Fixed a)+fixedFromDom = parseContent readContent++instance FromDom Scientific where+  fromDom = scientificFromDom++scientificFromDom :: Monad m => DomParserT Identity m Scientific+scientificFromDom = parseContent readContent++instance FromDom Bool where+  fromDom = boolFromDom++-- | Expects content to be y, yes, t, true or 1 for True Values n, no,+-- f, false or 0 for False. Case is not significant, blank characters+-- are striped.+boolFromDom :: (Monad m) => DomParserT Identity m Bool+boolFromDom = parseContent readBool++instance FromDom (Union '[]) where+  fromDom = empty++instance+  ( Typeable a, FromDom a, FromDom (Union as)+  , SubList as (a ': as) )+  => FromDom (Union (a ': as)) where+  -- fromDom :: forall m. (DomParserMonad m) => m a+  fromDom = (liftUnion <$> (proxyFromDom (Proxy :: Proxy a)))+    <|> (reUnion <$> (proxyFromDom (Proxy :: Proxy (Union as))))++unionFromDom+  :: (Monad m, FromDom (Union as))+  => proxy as+  -> DomParserT Identity m (Union as)+unionFromDom _ = fromDom++instance FromDom Element where+  fromDom = elementFromDom++elementFromDom :: (Monad m) => DomParserT Identity m Element+elementFromDom = view $ pdElements . to runIdentity

@@ -1,6 +1,19 @@ module Text.XML.DOM.Parser.Types-  ( -- * Parser internals-    DomPath+  (-- * Element matching+    ElemMatcher(..)+  , emMatch+  , emShow+  , matchElemName+  , elMatch+    -- * Name matching+  , NameMatcher(..)+  , nmMatch+  , nmShow+  , matchName+  , matchLocalName+  , matchCILocalName+    -- * Parser internals+  , DomPath(..)   , ParserError(..)   , pePath   , peDetails@@ -10,47 +23,140 @@   , ParserData(..)   , pdElements   , pdPath-    -- * Parser type   , DomParserT   , DomParser   , runDomParserT   , runDomParser     -- * Auxiliary-  , DomTraversable(..)   , throwParserError-  , throwWrongFormat   ) where -import           Control.Exception-import           Control.Lens-import           Control.Monad.Except-import           Control.Monad.Reader-import           Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NE-import           Data.Maybe-import           Data.Text (Text)-import           GHC.Generics (Generic)-import           Text.XML-import           Text.XML.Lens+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 -type DomPath = [Text]+-- | Arbitrary element matcher+--+-- @since 2.0.0+data ElemMatcher = ElemMatcher+  { _emMatch :: Element -> Bool+  , _emShow  :: Text+    -- ^ Field for 'Show' instance and bulding usefull errors+  } +makeLenses ''ElemMatcher++-- | Instance using instance of 'NameMatcher'+instance IsString ElemMatcher where+  fromString = matchElemName . fromString++instance Show ElemMatcher where+  show = T.unpack . _emShow++-- | Match element by name+--+-- @since 2.0.0+matchElemName :: NameMatcher -> ElemMatcher+matchElemName (NameMatcher matchName showName) = ElemMatcher+  { _emMatch = views name matchName+  , _emShow  = showName+  }++-- | Match over elements+--+-- @since 2.0.0+elMatch :: ElemMatcher -> Traversal' Element Element+elMatch (ElemMatcher match _) = filtered 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+  { _nmMatch :: Name -> Bool+    -- ^ Name matching function, usually should be simple comparsion+    -- function takin in account only local name or other components+    -- of 'Name'+  , _nmShow :: Text+    -- ^ Field for 'Show' instance and bulding usefull errors+  }++makeLenses ''NameMatcher++-- | Instance use 'matchCILocalName' as most general and liberal+-- matching strategy (while XML is often malformed).+--+-- @since 2.0.0+instance IsString NameMatcher where+  fromString = matchCILocalName . T.pack++instance Show NameMatcher where+  show = T.unpack . _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 tname = NameMatcher+  { _nmMatch = \n -> nameLocalName n == tname+  , _nmShow  = 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 tname = NameMatcher+  { _nmMatch = \n -> CI.mk (nameLocalName n) == CI.mk tname+  , _nmShow  = tname+  }++-- | Makes matcher which match name by 'Eq' with given+--+-- @since 2.0.0+matchName :: Name -> NameMatcher+matchName n = NameMatcher+  { _nmMatch = (== n)+  , _nmShow  = nameLocalName 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+  { unDomPath :: [Text]+  } deriving (Eq, Ord, Show, Monoid)+ -- | DOM parser error description. data ParserError   -- | Tag not found which should be.   = PENotFound     { _pePath :: DomPath+      -- ^ Path of element error occured in     } -  -- | Tag contents has wrong format, (could not read text to value)-  | PEWrongFormat-    { _peDetails :: Text-    , _pePath    :: DomPath     -- ^ path of element+  -- | Expected attribute but not found+  --+  -- @since 1.0.0+  | PEAttributeNotFound+    { _peAttributeName :: NameMatcher+    , _pePath          :: DomPath     }    -- | Could not parse attribute+  --+  -- @since 1.0.0   | PEAttributeWrongFormat-    { _peAttributeName :: Text+    { _peAttributeName :: NameMatcher     , _peDetails       :: Text     , _pePath          :: DomPath     }@@ -60,17 +166,17 @@     { _pePath :: DomPath     } -  -- | Expected attribute but not found-  | PEAttributeNotFound-    { _peAttributeName :: Text-    , _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 (Eq, Ord, Show, Generic)+    } deriving (Show, Generic)  makeLenses ''ParserError @@ -78,16 +184,17 @@  newtype ParserErrors = ParserErrors   { unParserErrors :: [ParserError]-  } deriving (Ord, Eq, Show, Monoid, Generic)+  } deriving (Show, Monoid, Generic)  makePrisms ''ParserErrors  instance Exception ParserErrors  -{- | Parser scope parser runs in. Functor argument is usually @Identity@ or-@[]@.+{- | 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.@@ -119,10 +226,11 @@   -> DomParserT Identity m a   -> m (Either ParserErrors a) runDomParserT doc par =-  let pd = ParserData-        { _pdElements = doc ^. root . to pure-        , _pdPath     = [doc ^. root . localName]-        }+  let+    pd = ParserData+      { _pdElements = doc ^. root . to pure+      , _pdPath     = DomPath [doc ^. root . name . to nameLocalName]+      }   in runExceptT $ runReaderT par pd  runDomParser@@ -131,36 +239,10 @@   -> Either ParserErrors a runDomParser doc par = runIdentity $ runDomParserT doc par --- | Class of traversable functors which may be constructed from list. Or may--- not.-class Traversable f => DomTraversable f where-  -- | If method return Nothing this means we can not build traversable from-  -- given list. In this case combinator should fail traversing.-  buildDomTraversable :: [a] ->  Maybe (f a)--instance DomTraversable Identity where-  buildDomTraversable = fmap Identity . listToMaybe--instance DomTraversable [] where-  buildDomTraversable = Just--instance DomTraversable Maybe where-  buildDomTraversable = Just . listToMaybe--instance DomTraversable NonEmpty where-  buildDomTraversable = NE.nonEmpty- throwParserError   :: (MonadError ParserErrors m, MonadReader (ParserData f) m)-  => ([Text] -> ParserError)+  => (DomPath -> ParserError)   -> m a throwParserError mkerr = do   path <- view pdPath-  throwError $ ParserErrors [mkerr path]---- | Throw 'PEWrongFormat' as very common case-throwWrongFormat-  :: (MonadError ParserErrors m, MonadReader (ParserData f) m)-  => Text-  -> m a-throwWrongFormat err = throwParserError $ PEWrongFormat err+  throwError $ ParserErrors $ [mkerr path]

@@ -33,7 +33,7 @@   int <- parseAttribute "int" readContent   bool <- parseAttribute "bool" readBool   return $ TestStructure-    { tsName  = name+    { tsName  = nameLocalName name     , tsInts  = [int]     , tsBools = pure bool } @@ -156,7 +156,7 @@   :: String                     -- ^ Name of spec   -> Document                   -- ^ Document to parse   -> (a -> Maybe String)        -- ^ Value checker, Nothing if all ok-  -> DomParser Identity a                -- ^ Parser itself+  -> DomParser Identity a       -- ^ Parser itself   -> Spec specParser name doc check parser = it name $ do   result <- either throwIO return $ runDomParser doc parser@@ -166,9 +166,9 @@  specParserEq   :: (Eq a, Show a)-  => String            -- ^ Name of spec-  -> Document          -- ^ Document to parse-  -> a                 -- ^ Value parser should return+  => String                     -- ^ Name of spec+  -> Document                   -- ^ Document to parse+  -> a                          -- ^ Value parser should return   -> DomParser Identity a       -- ^ Parser itself   -> Spec specParserEq name doc a parser = specParser name doc check parser@@ -193,7 +193,7 @@   :: (Show a)   => String                     -- ^ Name of spec   -> Document-  -> [Text]                     -- ^ Expteced path in error+  -> DomPath                     -- ^ Expteced path in error   -> DomParser Identity a   -> Spec specParserFailedPath name doc path parser = it name $ example $ do@@ -226,7 +226,7 @@       describe "deep" $ do         let parser = inElem "a" $ inElem "b" textFromDom         specParserFailedPath "docDeepMultiple2" docDeepMultiple2-          ["root", "a", "b"] parser+          (DomPath ["root", "a", "b"]) parser         -- should fail here because first tag "a" does not contains         -- tag "b" which is expected by parser @inElem "b"@ @@ -276,7 +276,7 @@         specParserEq "docDeepMultiple1" docDeepMultiple1 "content1" parser         specParserEq "docDeepMultiple2" docDeepMultiple2 "content1" parser       describe "fails" $ do-        specParserFailedPath "docSimple" docSimple ["root", "a", "b"] parser+        specParserFailedPath "docSimple" docSimple (DomPath ["root", "a", "b"]) parser     describe "multiple elements" $ do       let         parser = diveElem "a" $ inElemAll "b" textFromDom@@ -311,9 +311,9 @@         inElem "a" $ do           checkCurrentName "a"     describe "fails" $ do-      specParserFailedPath "root element" docSimple ["toor"] $ do+      specParserFailedPath "root element" docSimple (DomPath ["toor"]) $ do         checkCurrentName "toor"-      specParserFailedPath "inner element" docSimple ["root", "b"] $ do+      specParserFailedPath "inner element" docSimple (DomPath ["root", "b"]) $ do         inElem "a" $ checkCurrentName "b"  contentSpec :: Spec