dom-parser 0.0.1 → 0.1.0

raw patch · 8 files changed

+816/−620 lines, 8 filesdep +open-uniondep +type-fundep +xml-lensdep ~basenew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: open-union, type-fun, xml-lens

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +2/−2
• LICENSE +17/−27
• dom-parser.cabal +24/−12
• src/Text/XML/DOM/Parser.hs +7/−456
• src/Text/XML/DOM/Parser/Class.hs +144/−0
• src/Text/XML/DOM/Parser/Combinators.hs +239/−0
• src/Text/XML/DOM/Parser/Types.hs +149/−0
• test/Main.hs +234/−123

@@ -1,4 +1,4 @@ # CHANGELOG -## 0.0.1-* First working version+## 0.1.0+* Public release

@@ -1,30 +1,20 @@-Copyright (c) 2015, Aleksey Uimanov--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.+Copyright (c) 2016 Typeable.io contributors -    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.+Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions: -    * Neither the name of Aleksey Uimanov nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.+The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

@@ -1,47 +1,55 @@ name:                dom-parser-version:             0.0.1-synopsis:            Simple monad for parsing DOM-license:             BSD3+version:             0.1.0+synopsis:            Simple monadic DOM parser+license:             MIT license-file:        LICENSE-author:              Aleksey Uimanov-maintainer:          s9gf4ult@gmail.com+author:              Typeable.io contributors+maintainer:          makeit@typeable.io category:            XML build-type:          Simple extra-source-files:  CHANGELOG.md cabal-version:       >=1.10 -homepage:            https://github.com/s9gf4ult/dom-parser-source-repository head-  type:     git-  location: git@github.com:s9gf4ult/dom-parser.git- library   hs-source-dirs:      src   default-language:    Haskell2010   ghc-options:        -Wall-  default-extensions:  DataKinds+  default-extensions:  ConstraintKinds+                     , DataKinds                      , DeriveGeneric                      , FlexibleContexts                      , FlexibleInstances+                     , FunctionalDependencies+                     , GADTs+                     , GeneralizedNewtypeDeriving+                     , InstanceSigs                      , LambdaCase                      , MultiParamTypeClasses                      , MultiWayIf                      , OverloadedStrings                      , QuasiQuotes+                     , RankNTypes                      , ScopedTypeVariables                      , TemplateHaskell+                     , TupleSections                      , TypeFamilies                      , TypeOperators                      , UndecidableInstances   build-depends:       base >= 4.7 && < 5                      , lens                      , mtl+                     , open-union                      , semigroups                      , shakespeare                      , text                      , transformers+                     , type-fun                      , xml-conduit-  exposed-modules:     Text.XML.DOM.Parser+                     , xml-lens+  exposed-modules: Text.XML.DOM.Parser+                 , Text.XML.DOM.Parser.Class+                 , Text.XML.DOM.Parser.Combinators+                 , Text.XML.DOM.Parser.Types  test-suite test   type:             exitcode-stdio-1.0@@ -49,11 +57,13 @@   main-is:          Main.hs   default-language: Haskell2010   default-extensions:  DeriveGeneric+                     , FlexibleContexts                      , FlexibleInstances                      , LambdaCase                      , MultiParamTypeClasses                      , OverloadedStrings                      , QuasiQuotes+                     , RecordWildCards                      , ScopedTypeVariables                      , TemplateHaskell                      , TypeFamilies@@ -61,6 +71,8 @@                  , data-default                  , dom-parser                  , hspec+                 , lens+                 , semigroups                  , shakespeare                  , text                  , xml-conduit

@@ -1,458 +1,9 @@ module Text.XML.DOM.Parser-       ( -- * Parser internals-         ParserData(..)-       , pdCursor, pdAxis, pdPath-       , ParserError(..)-       , pePath, peDetails-       , ParserErrors(..)-       , throwParserError-       , renderPath-         -- * Parser itself-       , DomParser-       , runDomParser-       , ContentParser-         -- * Common parsers-       , unitFromDom-       , voidFromDom-       , textFromContent-       , stringFromContent-       , charFromContent-       , intFromContent-       , integerFromContent-       , doubleFromContent-       , fixedFromContent-       , boolFromContent-         -- * Parser classes-       , FromDom(..)-       , FromContent(..)-         -- * Combinators-       , inElem, inElems, nonEmptyInElems, maybeInElem, inElemsPred-       , inAxis, inDescendants, inTags-         -- * Content getters-       , tryCurrentContent, tryCurrentContentText-       , currentContent-       , tryCurrentName , currentName-       , tryCurrentAttr , currentAttr-       , elemContent, nonEmptyElemsContent, elemsContent, maybeElemContent-         -- * Helpers-       , fromContentR-       , CurrentContent(..)-         -- * Raw node getters-       , currentNodes-         -- * Checkers-       , checkCurrentLaxName, checkCurrentName-       ) where--import           Control.Applicative-import           Control.Exception-import           Control.Lens-import           Control.Monad-import           Control.Monad.Except-import           Control.Monad.Reader.Class-import           Control.Monad.Trans.Except-import           Control.Monad.Trans.Reader (Reader, runReader)-import           Data.Fixed-import           Data.Functor.Compose-import qualified Data.List as L-import           Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NE-import           Data.Maybe-import           Data.Text (Text)-import qualified Data.Text as T-import           Data.Traversable-import           Data.Typeable-import           Data.Void-import           GHC.Generics (Generic)-import           Text.Read (readMaybe)-import           Text.Shakespeare.Text (st)-import           Text.XML-import           Text.XML.Cursor---- | DOM parser error description.-data ParserError-  -- | Tag not found which should be.-  = PENotFound-    { _pePath :: ![Text]-    }--  -- | Tag contents has wrong format, (could not read text to value)-  | PEWrongFormat-    { _pePath :: ![Text]     -- ^ path of element-    , _peDetails :: Text-    }--  -- | Such tag name is not expected in this place-  | PEWrongTagName-    { _pePath    :: ![Text]-    , _peDetails :: !Text-    }--  -- | Node is not an element but should be-  | PENotElement-    { _pePath :: ![Text]-    }--  -- | Node should have text content, but it does not.-  | PEContentNotFound-    { _pePath :: ![Text]-    }--  -- | Any other error-  | PEOther-    { _pePath    :: ![Text]-    , _peDetails :: !Text-    } deriving (Eq, Ord, Show, Generic)--makeLenses ''ParserError-makePrisms ''ParserError-instance Exception ParserError--data ParserData = ParserData-    { _pdCursor :: !Cursor       -- ^ Cursor to current parser's environment-    , _pdAxis   :: !Axis         -- ^ Context axis to follow deeper-    , _pdPath   :: ![Text]       -- ^ Path for errors-    } deriving (Generic)--makeLenses ''ParserData--newtype ParserErrors = ParserErrors-  { unParserErrors :: [ParserError]-  } deriving (Ord, Eq, Show, Generic)--makeWrapped ''ParserErrors--instance Exception ParserErrors---- | Parser monad where all parsing actions live-type DomParser = ExceptT [ParserError] (Reader ParserData)---- | Content parser type. Parser is just a function taking Text and--- returning either error description or successfully parsed value.-type ContentParser a = Text -> Either Text a---- | Render path for showing error-renderPath :: [Text] -> String-renderPath [] = "document"-renderPath path-  = T.unpack-  $ mconcat-  $ L.intersperse ">" path--throwParserError :: ([Text] -> ParserError) -> DomParser a-throwParserError mkerr = do-  pd <- ask-  let err = mkerr $ pd ^. pdPath-  throwE [err]---nodeName :: Node -> Maybe Name-nodeName (NodeElement el) = Just $ elementName el-nodeName _ = Nothing----- | Run parser on root element of Document.-runDomParser :: Document-             -> DomParser a-             -> Either [ParserError] a-runDomParser doc par =-  let cur = fromDocument doc-      Just root = nameLocalName <$> nodeName (node cur)-      pd = ParserData-           { _pdCursor = cur-           , _pdAxis = pure-           , _pdPath = [root]-           }-  in runReader (runExceptT par) pd---- | Helper function, throws 'PENotFound' if second argument is empty--- list-takeFirstElem :: [Text] -> [a] -> DomParser a-takeFirstElem path []    = throwE $ [PENotFound path]-takeFirstElem _    (a:_) = return a----- | Find first element with given name in current element and run--- parser inside of found element. Throws PENotFound error if element--- not found.-inElem :: Text -> DomParser a -> DomParser a-inElem name p = do-  pd <- ask-  let newpath = (pd ^. pdPath) ++ [name]-  newcur <- takeFirstElem newpath-            $ (pd ^. pdCursor) $/ (pd ^. pdAxis) >=> (laxElement name)-  let newdata = ParserData-                { _pdCursor = newcur-                , _pdAxis   = pure-                , _pdPath   = newpath-                }-  local (const newdata) p---- | Generic elements combinator. Takes predicate filtering/converting--- list of cursors to some traversable (with posible filtering and/or--- reordering)-inElemsPred :: (Traversable f)-            => ([Cursor] -> f Cursor) -- ^ Some predicate like 'listToMaybe'-            -> Text                   -- ^ Name of tags to find in current tag-            -> DomParser a            -- ^ Parser to run inside found cursors-            -> DomParser (f a)-inElemsPred cpred name p = do-  pd <- ask-  let newpath = (pd ^. pdPath) ++ [name]-      curs    = cpred-                $ (pd ^. pdCursor)-                $/ (pd ^. pdAxis) >=> (laxElement name)-  for curs $ \cur -> do-    let newdata = ParserData-                  { _pdCursor = cur-                  , _pdAxis   = pure-                  , _pdPath   = newpath-                  }-    local (const newdata) p---- | Find all elements with gievn name in current element and run--- parser inside of this elements.-inElems :: Text -> DomParser a -> DomParser [a]-inElems = inElemsPred id--nonEmptyInElems :: Text -> DomParser a -> DomParser (NonEmpty a)-nonEmptyInElems name parser-    = (getCompose <$> inElemsPred (Compose . NE.nonEmpty) name parser)-  >>= maybe (throwParserError PENotFound) return---- | Try to find element with given name and run parser inside of--- it. If not found return Nothing-maybeInElem :: Text -> DomParser a -> DomParser (Maybe a)-maybeInElem = inElemsPred listToMaybe---- | Run parser within axis context. Expected to not use directly.-inAxis :: [Text]                -- ^ Path suffix to append to path before run parser-       -> Axis                  -- ^ Axis to append to context-       -> DomParser a           -- ^ Parser to run-       -> DomParser a-inAxis pathsuff axis parser = do-  local ( over pdAxis (>=> axis)-        . over pdPath (++ pathsuff) ) parser---- | Given parser will match inside specific-inTags :: [Text]                -- ^ Sequence of tag names parser must-                                -- match inside-       -> DomParser a           -- ^ Parser to run-       -> DomParser a-inTags names p =-  let axis = foldr (&/) pure $ map laxElement names-  in inAxis names axis p---- | Given parser will match tag in arbitrary deepness-inDescendants :: DomParser a -> DomParser a-inDescendants = inAxis ["*"] descendant---- | Return the name of current cursor we staying in. Return 'Nothing'--- if we are not staying on element node-tryCurrentName :: DomParser (Maybe Name)-tryCurrentName = do-  pd <- ask-  return $ nodeName $ node $ pd ^. pdCursor---- | Return name of current element the parser in.-currentName :: DomParser Name-currentName = tryCurrentName >>= \case-  Nothing -> throwParserError PENotElement-  Just name -> return name---- | Run predicate with current tag name. Parser fails if predicate--- returned (Just msg) or node is not an element.-checkCurrentName :: (Name -> Maybe Text) -- ^ name checking predicate-                 -> DomParser ()-checkCurrentName predicate = do-  n <- currentName-  case predicate n of-    Nothing -> return ()-    Just msg -> throwParserError $ \p -> PEWrongTagName p msg---- | Throw 'PEWrongTagName' if name of current element does not match--- with given.-checkCurrentLaxName :: Text -> DomParser ()-checkCurrentLaxName name =-  let msg = [st|Expected tag name: #{name}|]-      predicate n = if (nameLocalName n == name)-                    then Nothing-                    else Just msg-  in checkCurrentName predicate---- | Get concatenated text from current parser's node(s). If current--- context have no @Content@ nodes then return Nothing.-tryCurrentContentText :: DomParser (Maybe Text)-tryCurrentContentText = do-  pd <- ask-  let txt = (pd ^. pdCursor) $/ (pd ^. pdAxis) >=> content-  return $ case txt of-    [] -> Nothing-    x  -> Just $ mconcat x--tryCurrentContent :: ContentParser a -> DomParser (Maybe a)-tryCurrentContent cparse = do-  tmay <- tryCurrentContentText-  for tmay $ \t -> case cparse t of-    Left err -> throwParserError-                $ \p -> PEWrongFormat p err-    Right a -> pure a--currentContent :: ContentParser a -> DomParser a-currentContent cparse-   = tryCurrentContent cparse- >>= maybe (throwParserError PEContentNotFound) return--elemContent :: Text -> ContentParser a -> DomParser a-elemContent name cparse-  = inElem name-  $ currentContent cparse--nonEmptyElemsContent :: Text -> ContentParser a -> DomParser (NonEmpty a)-nonEmptyElemsContent name cparse-    = (NE.nonEmpty <$> elemsContent name cparse)-  >>= maybe (throwParserError PENotFound) return--elemsContent :: Text -> ContentParser a -> DomParser [a]-elemsContent name cparse-  = fmap catMaybes-  $ inElems name-  $ tryCurrentContent cparse--maybeElemContent :: Text -> ContentParser a -> DomParser (Maybe a)-maybeElemContent name cparse-  = fmap join-  $ maybeInElem name-  $ tryCurrentContent cparse---- | Take attribute from current node (if it is an element). Throws--- 'PENotFound' or 'PENotElement'-currentAttr :: Text -> DomParser Text-currentAttr aname = do-  pd <- ask-  let newpath = (pd ^. pdPath) ++ [mappend "attribute " aname]-  takeFirstElem newpath-    $ laxAttribute aname (pd ^. pdCursor)--tryCurrentAttr :: Text -> DomParser (Maybe Text)-tryCurrentAttr aname = do-  pd <- ask-  return $ listToMaybe $ laxAttribute aname $ pd ^. pdCursor---- | Always successfully parses any DOM to @()@-unitFromDom :: DomParser ()-unitFromDom = pure ()---- | Never parses successfully. It is just 'mzero'-voidFromDom :: DomParser Void-voidFromDom = mzero---- | Does not strip content. Returns content unmodified.-textFromContent :: ContentParser Text-textFromContent = Right---- | Does not strip content. Returns content unmodified.-stringFromContent :: ContentParser String-stringFromContent = Right . T.unpack---- | Expects content to be a singe non-blank character. Blank characters--- are stripped to parse pretty-printed XML files.-charFromContent :: ContentParser Char-charFromContent t = case T.unpack $ T.strip t of-  [a] -> Right a-  x -> let msg = [st|Tag sould contain exactly one char, but it contains: #{x}|]-       in Left msg--intFromContent :: ContentParser Int-intFromContent = fromContentR--integerFromContent :: ContentParser Integer-integerFromContent = fromContentR--doubleFromContent :: ContentParser Double-doubleFromContent = fromContentR--fixedFromContent :: (HasResolution a, Typeable a) => ContentParser (Fixed a)-fixedFromContent = fromContentR---- | 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.-boolFromContent :: ContentParser Bool-boolFromContent 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 Left msg---- | Typeclass for structures which may be parsed from XML--- DOM. Usually you should pass parsing function explicitly to--- combinators like 'inElem', 'maybeInElem' or 'inTags' , but--- sometimes you need term search. Especially when you try to parse--- polymorphic types. Or you maybe generate parser with TH for your--- types, so typeclass would be convenient also.-class FromDom a where-  fromDom :: DomParser a--instance FromDom () where-  fromDom = unitFromDom---- | Usually you should pass 'ContentParser' to combinators like--- 'elemContent' or 'maybeElemContent' explicitly. But sometimes you--- need term search. Especially for code generated with TH.-class FromContent a where-  -- | Should return either error message (what was wrong) or parsed-  -- value-  fromContent :: ContentParser a--instance FromContent Text where-  fromContent t = Right t--instance FromContent String where-  fromContent t = pure $ T.unpack t--instance FromContent Char where-  fromContent = charFromContent--fromContentR :: forall a. (Read a, Typeable a) => Text -> Either Text a-fromContentR t = case readMaybe $ T.unpack $ T.strip t of-  Nothing ->-    let name = typeRep (Proxy :: Proxy a)-    in Left [st|Unreadable #{show name}: #{t}|]-  Just x  -> Right x--instance FromContent Int where-  fromContent = intFromContent--instance FromContent Integer where-  fromContent = integerFromContent--instance FromContent Double where-  fromContent = doubleFromContent--instance (HasResolution a, Typeable a) => FromContent (Fixed a) where-  fromContent = fixedFromContent---- | This isntance might be not very obvious but anyway-instance FromContent Bool where-  fromContent = boolFromContent---- | Helper newtype returning 'currentContent' for any type with--- instance 'FromContent'-newtype CurrentContent a = CurrentContent-  { unCurrentContent :: a-  } deriving (Ord, Eq, Show, Generic)--instance (FromContent a) => FromDom (CurrentContent a) where-  fromDom = CurrentContent <$> currentContent fromContent+  ( module Text.XML.DOM.Parser.Class+  , module Text.XML.DOM.Parser.Combinators+  , module Text.XML.DOM.Parser.Types+  ) where --- | Get children nodes from current parser's node.-currentNodes :: DomParser [Node]-currentNodes = do-  pd <- ask-  let curs = (pd ^. pdCursor) $/ (pd ^. pdAxis)-  return $ fmap node curs+import Text.XML.DOM.Parser.Class+import Text.XML.DOM.Parser.Combinators+import Text.XML.DOM.Parser.Types

@@ -0,0 +1,144 @@+module Text.XML.DOM.Parser.Class+  ( -- * FromDom+    FromDom(..)+  , proxyFromDom+    -- * Explicit methods for convenience+  , 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 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 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++-- | 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 $ \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++-- | 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

@@ -0,0 +1,239 @@+module Text.XML.DOM.Parser.Combinators+  ( -- * Generic combinators to traverse descendants+    traverseElems+  , inFilteredTrav+    -- * Using 'DomTraversable'+  , inElemTrav+  , inElem+  , inElemAll+  , inElemMay+  , inElemNe+    -- * Dive combinators+  , divePath+  , diveElem+    -- * Explicit ignoring elements+  , ignoreElem+  , ignoreEmpty+  , ignoreBlank+    -- * Checking current element properties+  , checkCurrentName+    -- * Parsing arbitrary content+  , parseContent+  , readContent+  ) where++import           Control.Lens+import           Control.Monad.Except+import           Control.Monad.Reader+import           Data.List.NonEmpty (NonEmpty(..))+import           Data.Monoid+import           Data.Text (Text)+import qualified Data.Text as T+import           Data.Traversable+import           Data.Typeable+import           Text.Read+import           Text.Shakespeare.Text (st)+import           Text.XML+import           Text.XML.DOM.Parser.Types+import           Text.XML.Lens+++-- | Generic function to traverse arbitrary inner cursors.+traverseElems+  :: (Monad m, Foldable g, Traversable f)+  => ([Element] -> DomParserT g m (f ([Text], Element)))+     -- ^ Takes set of current elements and+  -> DomParserT Identity m a+     -- ^ Parser will be runned for each element found in traversable+  -> 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++-- | Takes function filtering+inFilteredTrav+  :: (Monad m, Foldable g, DomTraversable f)+  => ([Element] -> ([Text], [Element]))+   -- ^ Function returning some filtered elements with path suffixes which will+   -- be appended to parser's state+  -> 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+        Nothing -> throwParserError $ PENotFound . (<> path)+        Just tr -> return $ fmap (path,) tr++inElemTrav+  :: (Monad m, Foldable g, DomTraversable f)+  => Text+  -> DomParserT Identity m a+  -> DomParserT g m (f a)+inElemTrav n = inFilteredTrav deeper+  where+    deeper = ([n],) . toListOf (folded . nodes . folded . _Element . ell n)++-- | Runs parser inside first children element with given name+inElem+  :: (Monad m, Foldable g)+  => Text+  -> DomParserT Identity m a+  -> DomParserT g m a+inElem n = fmap runIdentity . inElemTrav n++inElemAll+  :: (Monad m, Foldable g)+  => Text+  -> DomParserT Identity m a+  -> DomParserT g m [a]+inElemAll = inElemTrav++inElemMay+  :: (Monad m, Foldable g)+  => Text+  -> DomParserT Identity m a+  -> DomParserT g m (Maybe a)+inElemMay = inElemTrav++inElemNe+  :: (Monad m, Foldable g)+  => Text+  -> 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+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+elements. Consider this code++@+inElem "a" $ inElem "b" $ inElemAll "c" fromDom+@++which translates to pseudo-CSS query like: @a:nth(1) > b:nth(1) > c > fromDom@++@+divePath ["a", "b"] $ inElemAll "c" fromDom+@++which translates like: @a > b > c > fromDom@++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.+-}++divePath+  :: forall m g a+   . (Monad m, Foldable g)+  => [Text]+  -> DomParserT [] m a+  -> DomParserT g m a+divePath path = magnify $ to modElems+  where+    modElems+      = over pdElements (toListOf $ folded . diver)+      . over pdPath (<> path)+    diver :: Fold Element Element+    diver    = foldr (.) id $ map toDive path+    toDive n = nodes . folded . _Element . ell n++diveElem+  :: (Monad m, Foldable g)+  => Text+  -> DomParserT [] m a+  -> DomParserT g m a+diveElem p = divePath [p]++-- | Ignore arbitrary current element if it conforms to predicate.+ignoreElem+  :: (Monad m)+  => (Element -> Bool)+     -- ^ Predicate checking that we must ignore some current tag. If returns+     -- true then parser will not be runned and combinator just returns Nothing.+  -> DomParserT Identity m a+  -> DomParserT Identity m (Maybe a)+ignoreElem test parser = do+  ign <- view $ pdElements . to (test . runIdentity)+  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+-- XML with strange empty elements which must be just ignored, but `inElem` runs+-- parser inside of this elements which causes to parser error.+ignoreEmpty+  :: (Monad m)+  => DomParserT Identity m a+  -> DomParserT Identity m (Maybe a)+ignoreEmpty = ignoreElem test+  where+    test e = null $ e ^. nodes++-- | If all current elements contains blank content, or contains nothing at all+-- , then returns Nothing, else runs parser.+ignoreBlank+  :: (Monad m)+  => DomParserT Identity m a+  -> DomParserT Identity m (Maybe a)+ignoreBlank = ignoreElem test+  where+    test e =+      let+        elems = e ^.. nodes . folded . _Element+        cont = mconcat $ e ^.. nodes . folded . _Content+      in if | not $ null elems      -> False+            | T.null $ T.strip cont -> True+            | otherwise             -> False++-- | 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 <- view $ pdElements . to runIdentity . localName+  unless (cn == n) $ do+    p <- view pdPath+    let pinit = if null p then [] else init p+    throwError $ ParserErrors [PENotFound $ pinit ++ [n]]+  return ()++-- | Parses content inside current tag. It expects current element set consists+-- of exactly ONE element. Throws error if current elements set contains+-- multiple of them.+parseContent+  :: (Monad m)+  => (Text -> DomParserT Identity m a)+  -> DomParserT Identity m a+parseContent parse = do+  e <- view $ pdElements . to runIdentity+  let+    nds = e ^. nodes+    els = nds ^.. folded . _Element+    conts = nds ^.. folded . _Content+  when (not $ null els) $ throwParserError PEContentNotFound+  when (null conts) $ throwParserError PEContentNotFound+  parse $ mconcat conts++readContent+  :: forall m g a+   . (Read a, Typeable a, Monad m)+  => Text+  -> DomParserT g m a+readContent t = case readMaybe $ T.unpack t of+  Nothing -> throwParserError $ PEWrongFormat [st|Not readable #{n}: #{t}|]+  Just a  -> pure a+  where+    n = show $ typeRep (Proxy :: Proxy a)

@@ -0,0 +1,149 @@+module Text.XML.DOM.Parser.Types+  ( -- * Parser internals+    ParserError(..)+  , pePath+  , peDetails+  , ParserErrors(..)+  , _ParserErrors+  , 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++-- | DOM parser error description.+data ParserError+  -- | Tag not found which should be.+  = PENotFound+    { _pePath :: [Text]+    }++  -- | Tag contents has wrong format, (could not read text to value)+  | PEWrongFormat+    { _peDetails :: Text+    , _pePath    :: [Text]     -- ^ path of element+    }++  -- | Node should have text content, but it does not.+  | PEContentNotFound+    { _pePath :: [Text]+    }++  -- | Some other error+  | PEOther+    { _peDetails :: Text+    , _pePath    :: [Text]+    } deriving (Eq, Ord, Show, Generic)++makeLenses ''ParserError++instance Exception ParserError++newtype ParserErrors = ParserErrors+  { unParserErrors :: [ParserError]+  } deriving (Ord, Eq, Show, Monoid, Generic)++makePrisms ''ParserErrors++instance Exception ParserErrors+++{- | Parser scope parser runs in. 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+    { _pdElements :: f Element+      -- ^ Current element(s). Functor is intended to be either @Identity@ or+      -- @[]@+    , _pdPath     :: [Text]+      -- ^ 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 doc par =+  let pd = ParserData+        { _pdElements = doc ^. root . to pure+        , _pdPath     = [doc ^. root . localName]+        }+  in runExceptT $ runReaderT par pd++runDomParser+  :: Document+  -> DomParser Identity a+  -> 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)+  -> 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

@@ -1,76 +1,133 @@ module Main where -import           Control.Applicative import           Control.Exception-import           Data.Char+import           Control.Lens+import           Control.Monad import           Data.Default-import           Data.Maybe-import qualified Data.Text as T+import           Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE+import           Data.Monoid+import           Data.Text (Text) import           Test.Hspec-import           Text.Shakespeare.Text ( lt )+import           Text.Shakespeare.Text (lt) import           Text.XML import           Text.XML.DOM.Parser -cleanDoc :: Document -> Document-cleanDoc (Document p root msc)-  = Document p (cleanE root) msc-  where-    cleanE (Element n a nodes)-      = Element n a $ catMaybes $ map cleanN nodes-    cleanN (NodeContent t) | allSpaces t = Nothing-                           | otherwise   = Just $ NodeContent t-    cleanN (NodeComment _) = Nothing-    cleanN (NodeElement e) = Just $ NodeElement $ cleanE e-    allSpaces t = all isSpace $ T.unpack t -simpleDoc :: Document-simpleDoc = cleanDoc $ parseText_ def-    [lt|+data TestStructure = TestStructure+  { tsName  :: Text+  , tsInts  :: [Int]+  , tsBools :: NonEmpty Bool+  } deriving (Eq, Show)++testStructureFromDom :: (Monad m) => DomParserT Identity m TestStructure+testStructureFromDom = do+  tsName <- inElem "name" fromDom+  tsInts <- inElemAll "int" intFromDom+  tsBools <- inElemNe "bool" boolFromDom+  return TestStructure{..}++instance FromDom TestStructure where+  fromDom = testStructureFromDom++docStruct :: Document+docStruct = parseText_ def [lt| <?xml version="1.0" encoding="utf-8"?> <root>+  <name>name</name>+  <int>1</int>+  <int>2</int>+  <bool>t</bool>+</root>+|]++docNone :: Document+docNone = parseText_ def [lt|+<?xml version="1.0" encoding="utf-8"?>+<root>+</root>+|]++docEmpty :: Document+docEmpty = parseText_ def [lt|+<?xml version="1.0" encoding="utf-8"?>+<root>+  <a/>+</root>+|]++docSimple :: Document+docSimple = parseText_ def [lt|+<?xml version="1.0" encoding="utf-8"?>+<root>+  <a>content</a>+</root>+|]++docMultiple :: Document+docMultiple = parseText_ def [lt|+<?xml version="1.0" encoding="utf-8"?>+<root>+  <a>content1</a>+  <a>content2</a>+  <a>content3</a>+</root>+|]++docDeep :: Document+docDeep = parseText_ def [lt|+<?xml version="1.0" encoding="utf-8"?>+<root>+  <a><b>content</b></a>+</root>+|]++docDeepWithContent :: Document+docDeepWithContent = parseText_ def [lt|+<?xml version="1.0" encoding="utf-8"?>+<root>+  <a>content<b>content</b>content</a>+</root>+|]++docDeepMultiple1 :: Document+docDeepMultiple1 = parseText_ def [lt|+<?xml version="1.0" encoding="utf-8"?>+<root>   <a>-    <b>content</b>+    <b>content1</b>+    <b>content2</b>   </a>+  <a>+    <b>content3</b>+  </a>+  <a/> </root>-  |]+|] -complexDoc :: Document-complexDoc = cleanDoc $ parseText_ def-    [lt|+docDeepMultiple2 :: Document+docDeepMultiple2 = parseText_ def [lt| <?xml version="1.0" encoding="utf-8"?> <root>-  <elem1>-    <elem2>-      <elem3>-        <cont>first</cont>-      </elem3>-    </elem2>-    <elem2>-      <elem3>-        <cont>first</cont>-      </elem3>-    </elem2>-  </elem1>-  <tag1>-    <tag2>-      <tag3>-        <cont>second</cont>-        <cont>second</cont>-      </tag3>-    </tag2>-  </tag1>+  <a/>+  <a>+    <b>content1</b>+  </a>+  <a>+    <b>content2</b>+    <b>content3</b>+  </a> </root>-  |]+|]  specParser   :: String                     -- ^ Name of spec   -> Document                   -- ^ Document to parse   -> (a -> Maybe String)        -- ^ Value checker, Nothing if all ok-  -> DomParser a                -- ^ Parser itself+  -> DomParser Identity a                -- ^ Parser itself   -> Spec specParser name doc check parser = it name $ do-  result <- either (throwIO . last) return-          $ runDomParser doc parser+  result <- either throwIO return $ runDomParser doc parser   case check result of     Nothing -> return ()     Just e  -> throwIO $ ErrorCall e@@ -80,7 +137,7 @@   => String            -- ^ Name of spec   -> Document          -- ^ Document to parse   -> a                 -- ^ Value parser should return-  -> DomParser a       -- ^ Parser itself+  -> DomParser Identity a       -- ^ Parser itself   -> Spec specParserEq name doc a parser = specParser name doc check parser   where@@ -88,92 +145,146 @@             | otherwise = Just $ "should be " ++ show a                           ++ " but got " ++ show x -specParserEqFailed :: (Show a)-                 => String-                 -> Document-                 -> DomParser a-                 -> Spec-specParserEqFailed name doc parser = it name $ do+specParserFailed+  :: (Show a)+  => String+  -> Document+  -> DomParser Identity a+  -> Spec+specParserFailed name doc parser = it name $ example $ do   let result = runDomParser doc parser   case result of     Right a -> fail $ "Expected parser to fail, but returned" ++ (show a)-    Left _  -> return () :: IO ()--spec :: Spec-spec = describe "DOM Parser" $ do-  describe "alternative instance" $ do-    let firstP = inTags ["elem1", "elem2", "elem3" ] $ elemsContent "cont" textFromContent-        secondP = inTags ["tag1", "tag2", "tag3"] $ elemsContent "cont" textFromContent-        firstR = replicate 2 "first"-        secondR = replicate 2 "second"-    specParserEq "empty first" complexDoc firstR $ empty <|> firstP-    specParserEq "empty last" complexDoc firstR $ firstP <|> empty-    specParserEq "first first" complexDoc firstR $ firstP <|> secondP-    specParserEq "second first" complexDoc secondR $ secondP <|> firstP--  describe "simple DOM tests" $ do-    specParserEq "inElem" simpleDoc "content" $ do-      inElem "a" $ elemContent "b" textFromContent-    specParserEq "inElems" simpleDoc ["content"] $ do-      inElems "a" $ elemContent "b" textFromContent--    specParserEq "inDescendants" simpleDoc "content" $ do-      inDescendants $ elemContent "b" textFromContent-    specParserEq "inTags" simpleDoc "content" $ do-      inTags ["a"] $ elemContent "b" textFromContent--    let oneElem x = case length x of-          1 -> Nothing-          l -> Just $ "length of nodes list is wrong: " ++ show x-    specParser "currentNodes" simpleDoc oneElem $ do-      inTags ["a"] $ currentNodes+    Left _  -> return () -  describe "complex DOM tests" $ do-    specParserEq "inElems" complexDoc (replicate 2 "first") $ do-      inElem "elem1"-        $ inElems "elem2"-        $ inElem "elem3"-        $ elemContent "cont" textFromContent+specParserFailedPath+  :: (Show a)+  => String                     -- ^ Name of spec+  -> Document+  -> [Text]                     -- ^ Expteced path in error+  -> DomParser Identity a+  -> Spec+specParserFailedPath name doc path parser = it name $ example $ do+  let result = runDomParser doc parser+  case result of+    Right a   -> fail $ "Expected parser to fail, but returned" ++ (show a)+    Left (ParserErrors errs) -> case errs ^? folded . pePath of+      Nothing -> fail $ "Parser failed, but got no errors to analyze path"+      Just p | p == path -> return ()+             | otherwise -> fail $ "Path is not exptected: " <> show p -    specParserEq "currentName" complexDoc "elem3" $ do-      inDescendants $ inElem "elem3" $ currentName+combinationsSpec :: Spec+combinationsSpec = do+  describe "inElem" $ do+    let parser = inElem "a" textFromDom+    describe "succeeds" $ do+      specParserEq "docSimple" docSimple "content" parser+      specParserEq "docMultiple" docMultiple "content1" parser+    describe "fails" $ do+      specParserFailed "docNone" docNone parser+      specParserFailed "docEmpty" docEmpty parser -    specParserEq "first correct parser" complexDoc (replicate 2 "first") $ do-      inElem "elem1" $ do-        inElems "elem2" $ do-          inElem "elem3" $ elemContent "cont" textFromContent+  describe "inElemAll" $ do+    let parser = inElemAll "a" textFromDom+    describe "succeeds" $ do+      specParserEq "docNone" docNone [] parser+      specParserEq "docSimple" docSimple ["content"] parser+      specParserEq "docMultiple" docMultiple+        ["content1", "content2", "content3"] parser+    describe "fails" $ do+      specParserFailed "docEmpty" docEmpty parser -    specParserEqFailed "first incorrect parser" complexDoc $ do-      inElem "elem1" $ do-        inElem "elem3" $ do     -- wrong nesting-          inElem "elem2" $ elemsContent "cont" textFromContent+  describe "inElemMay" $ do+    let parser = inElemMay "a" textFromDom+    describe "succeeds" $ do+      specParserEq "docNone" docNone Nothing parser+      specParserEq "docSimple" docSimple (Just "content") parser+      specParserEq "docMultiple" docMultiple (Just "content1") parser+    describe "fails" $ do+      specParserFailed "docEmpty" docEmpty parser -    -- Same parser as previous but do not care of elements structure-    specParserEq "first simple parser" complexDoc (replicate 2 "first") $ do-      inElem "elem1" $ inDescendants $ do-        elemsContent "cont" textFromContent+  describe "inElemNe" $ do+    let parser = inElemNe "a" textFromDom+    describe "succeeds" $ do+      specParserEq "docSimple" docSimple (pure "content") parser+      specParserEq "docMultiple" docMultiple+        (NE.fromList ["content1", "content2", "content3"]) parser+    describe "fails" $ do+      specParserFailed "docNone" docNone parser+      specParserFailed "docEmpty" docEmpty parser -    specParserEq "first simplier parser" complexDoc (replicate 2 "first") $ do-      inTags ["elem1", "elem2", "elem3"] $ elemsContent "cont" textFromContent+  describe "diveElem" $ do+    describe "single element" $ do+      let parser = diveElem "a" $ inElem "b" textFromDom+      describe "succeeds" $ do+        specParserEq "docDeepMultiple1" docDeepMultiple1 "content1" parser+        specParserEq "docDeepMultiple2" docDeepMultiple2 "content1" parser+      describe "fails" $ do+        specParserFailedPath "docSimple" docSimple ["root", "a", "b"] parser+    describe "multiple elements" $ do+      let+        parser = diveElem "a" $ inElemAll "b" textFromDom+        result = ["content1", "content2", "content3"]+      describe "succeeds" $ do+        specParserEq "docDeepMultiple1" docDeepMultiple1 result parser+        specParserEq "docDeepMultiple2" docDeepMultiple2 result parser+        specParserEq "docSimple" docSimple [] parser -    specParserEq "first simplier parser other way" complexDoc (replicate 2 "first") $ do-      inTags ["elem1", "elem2", "elem3"] $ inElems "cont" $ currentContent textFromContent+  describe "ignoreEmpty" $ do+    describe "mandatory element" $ do+      let parser = inElem "a" $ ignoreEmpty textFromDom+      describe "succeeds" $ do+        specParserEq "docEmpty" docEmpty Nothing parser+        specParserEq "docSimple" docSimple (Just "content") parser+        specParserEq "docMultiple" docMultiple (Just "content1") parser+      describe "fails" $ do+        specParserFailed "docNone" docNone parser+    describe "optional element" $ do+      let parser = fmap join $ inElemMay "a" $ ignoreEmpty textFromDom+      describe "succeeds" $ do+        specParserEq "docNone" docNone Nothing parser+        specParserEq "docEmpty" docEmpty Nothing parser+        specParserEq "docSimple" docSimple (Just "content") parser+        specParserEq "docMultiple" docMultiple (Just "content1") parser -    specParserEq "second correct parser" complexDoc (replicate 2 "second") $ do-      inElem "tag1" $ do-        inElem "tag2" $ do-          inElem "tag3" $ elemsContent "cont" textFromContent+  describe "checkCurrentName" $ do+    describe "succeeded" $ do+      specParserEq "root element" docSimple () $ do+        checkCurrentName "root"+      specParserEq "inner element" docSimple () $ do+        inElem "a" $ do+          checkCurrentName "a"+    describe "fails" $ do+      specParserFailedPath "root element" docSimple ["toor"] $ do+        checkCurrentName "toor"+      specParserFailedPath "inner element" docSimple ["root", "b"] $ do+        inElem "a" $ checkCurrentName "b" -    specParserEq "second simple parser" complexDoc (replicate 2 "second") $ do-      inTags ["tag1", "tag2", "tag3"] $ elemsContent "cont" textFromContent+contentSpec :: Spec+contentSpec = do+  describe "fails if inner element found" $ do+    specParserFailed "docDeep" docDeep $ do+      inElem "a" $ textFromDom+    specParserFailed "docDeepWithContent" docDeepWithContent $ do+      inElem "a" $ textFromDom -    let lenTwo x = case length x of-          2 -> Nothing-          l -> Just $ "length is not 2: " ++ show x-    specParser "currentNodes" complexDoc lenTwo $ do-      inElem "elem1" $ do-        inTags ["elem2", "elem3"] $ do-          currentNodes+structSpec :: Spec+structSpec = do+  describe "succeeds" $ do+    let+      result = TestStructure+                 { tsName = "name"+                 , tsInts = [1,2]+                 , tsBools = pure True }+    specParserEq "docStruct" docStruct result fromDom+  describe "fails" $ do+    specParserFailed "docSimple" docSimple testStructureFromDom  main :: IO ()-main = hspec spec+main = hspec $ do+  describe "combinators" $ do+    combinationsSpec+  describe "content parsing" $ do+    contentSpec+  describe "expected struct" $ do+    structSpec