dom-parser 0.1.1 → 1.0.0

raw patch · 6 files changed

+256/−72 lines, 6 filesdep +containersdep ~type-funPVP ok

version bump matches the API change (PVP)

Dependencies added: containers

Dependency ranges changed: type-fun

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• dom-parser.cabal +12/−4
• src/Text/XML/DOM/Parser/Class.hs +22/−12
• src/Text/XML/DOM/Parser/Combinators.hs +105/−29
• src/Text/XML/DOM/Parser/Types.hs +23/−6
• test/Main.hs +88/−21

@@ -1,4 +1,10 @@ # CHANGELOG +## 1.0.0+* Added support for parsing attributes+* Changed public interface for 'parseContent'+* Added usefull functions+* Dropped unnecessary dependency from shakespeare+ ## 0.1.0 * Public release

@@ -1,5 +1,5 @@ name:                dom-parser-version:             0.1.1+version:             1.0.0 synopsis:            Simple monadic DOM parser license:             MIT license-file:        LICENSE@@ -10,6 +10,14 @@ extra-source-files:  CHANGELOG.md cabal-version:       >=1.10 +extra-source-files: CHANGELOG.md++homepage:            https://github.com/typeable/dom-parser++source-repository head+  type:     git+  location: git@github.com:typeable/dom-parser.git+ library   hs-source-dirs:      src   default-language:    Haskell2010@@ -36,14 +44,14 @@                      , TypeOperators                      , UndecidableInstances   build-depends:       base >= 4.7 && < 5+                     , containers                      , lens                      , mtl-                     , open-union >= 0.2+                     , open-union                      , semigroups-                     , shakespeare                      , text                      , transformers-                     , type-fun >= 0.1.1+                     , type-fun                      , xml-conduit                      , xml-lens   exposed-modules: Text.XML.DOM.Parser

@@ -8,11 +8,13 @@   , textFromDom   , stringFromDom   , charFromDom+  , readChar   , intFromDom   , integerFromDom   , doubleFromDom   , fixedFromDom   , boolFromDom+  , readBool   , unitFromDom   , voidFromDom   ) where@@ -20,12 +22,12 @@ 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.Shakespeare.Text (st) import           Text.XML import           Text.XML.DOM.Parser.Combinators import           Text.XML.DOM.Parser.Types@@ -95,17 +97,22 @@ unionFromDom _ = fromDom  textFromDom :: (Monad m) => DomParserT Identity m Text-textFromDom = parseContent pure+textFromDom = parseContent Right  stringFromDom :: (Monad m) => DomParserT Identity m String-stringFromDom = parseContent $ pure . T.unpack+stringFromDom = parseContent $ Right . 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"+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 @@ -124,16 +131,19 @@ -- 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 ->+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 -> return True-        | lowt `elem` fvals -> return False+  in if | lowt `elem` tvals -> Right True+        | lowt `elem` fvals -> Right False         | otherwise         ->-          let msg = [st|Could not read "#{t}" as Bool|]-          in throwParserError $ PEWrongFormat msg+            Left $ "Could not read " <> t <> " as Bool"  -- | Always successfully parses any DOM to @()@ unitFromDom :: (Monad m) => DomParserT Identity m  ()

@@ -15,24 +15,32 @@   , ignoreElem   , ignoreEmpty   , ignoreBlank-    -- * Checking current element properties+    -- * Getting current element's properties+  , getCurrentName+  , getCurrentContent+  , getCurrentAttributes+  , getCurrentAttribute+    -- * Current element's checks   , checkCurrentName-    -- * Parsing arbitrary content+    -- * 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.Shakespeare.Text (st) import           Text.XML import           Text.XML.DOM.Parser.Types import           Text.XML.Lens@@ -41,8 +49,10 @@ -- | 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+  => ([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+     -- to run parser in   -> DomParserT Identity m a      -- ^ Parser will be runned for each element found in traversable   -> DomParserT g m (f a)@@ -53,12 +63,13 @@     let newpd = ParserData           { _pdElements = Identity e           , _pdPath     = pd ^. pdPath <> subpath }-    magnify (to $ const newpd) parser+    magnify (to $ const newpd) parser -- type of reader is changed, so+                                      -- local does not work  -- | Takes function filtering inFilteredTrav   :: (Monad m, Foldable g, DomTraversable f)-  => ([Element] -> ([Text], [Element]))+  => ([Element] -> (DomPath, [Element]))    -- ^ Function returning some filtered elements with path suffixes which will    -- be appended to parser's state   -> DomParserT Identity m a@@ -160,7 +171,7 @@   :: (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.+     -- '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@@ -195,6 +206,12 @@             | 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.@@ -203,37 +220,96 @@   => Text   -> DomParserT Identity m () checkCurrentName n = do-  cn <- view $ pdElements . to runIdentity . localName+  cn <- getCurrentName   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+-- | 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-    nds = e ^. nodes+    els :: [Element]     els = nds ^.. folded . _Element+    conts :: [Text]     conts = nds ^.. folded . _Content-  when (not $ null els) $ throwParserError PEContentNotFound-  when (null conts) $ throwParserError PEContentNotFound-  parse $ mconcat conts+  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-  :: forall m g a-   . (Read a, Typeable a, Monad m)+  :: (Read a, Typeable a)   => 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+  -> 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-    n = show $ typeRep (Proxy :: Proxy a)+    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

@@ -1,8 +1,10 @@ module Text.XML.DOM.Parser.Types   ( -- * Parser internals-    ParserError(..)+    DomPath+  , ParserError(..)   , pePath   , peDetails+  , peAttributeName   , ParserErrors(..)   , _ParserErrors   , ParserData(..)@@ -31,28 +33,43 @@ import           Text.XML import           Text.XML.Lens +type DomPath = [Text]+ -- | DOM parser error description. data ParserError   -- | Tag not found which should be.   = PENotFound-    { _pePath :: [Text]+    { _pePath :: DomPath     }    -- | Tag contents has wrong format, (could not read text to value)   | PEWrongFormat     { _peDetails :: Text-    , _pePath    :: [Text]     -- ^ path of element+    , _pePath    :: DomPath     -- ^ path of element     } +  -- | Could not parse attribute+  | PEAttributeWrongFormat+    { _peAttributeName :: Text+    , _peDetails       :: Text+    , _pePath          :: DomPath+    }+   -- | Node should have text content, but it does not.   | PEContentNotFound-    { _pePath :: [Text]+    { _pePath :: DomPath     } +  -- | Expected attribute but not found+  | PEAttributeNotFound+    { _peAttributeName :: Text+    , _pePath          :: DomPath+    }+   -- | Some other error   | PEOther     { _peDetails :: Text-    , _pePath    :: [Text]+    , _pePath    :: DomPath     } deriving (Eq, Ord, Show, Generic)  makeLenses ''ParserError@@ -86,7 +103,7 @@     { _pdElements :: f Element       -- ^ Current element(s). Functor is intended to be either @Identity@ or       -- @[]@-    , _pdPath     :: [Text]+    , _pdPath     :: DomPath       -- ^ Path for error reporting     } 

@@ -27,8 +27,15 @@   tsBools <- inElemNe "bool" boolFromDom   return TestStructure{..} -instance FromDom TestStructure where-  fromDom = testStructureFromDom+testStructureAttributes :: (Monad m) => DomParserT Identity m TestStructure+testStructureAttributes = do+  name <- getCurrentName+  int <- parseAttribute "int" readContent+  bool <- parseAttribute "bool" readBool+  return $ TestStructure+    { tsName  = name+    , tsInts  = [int]+    , tsBools = pure bool }  docStruct :: Document docStruct = parseText_ def [lt|@@ -41,6 +48,13 @@ </root> |] +docAttrStruct :: Document+docAttrStruct = parseText_ def [lt|+<?xml version="1.0" encoding="utf-8"?>+<structure int="10" bool="t">+</structure>+|]+ docNone :: Document docNone = parseText_ def [lt| <?xml version="1.0" encoding="utf-8"?>@@ -48,10 +62,28 @@ </root> |] -docEmpty :: Document-docEmpty = parseText_ def [lt|+docSimpleAttr :: Document+docSimpleAttr = parseText_ def [lt| <?xml version="1.0" encoding="utf-8"?> <root>+<a attr="content"/>+</root>+|]++docMultipleAttr :: Document+docMultipleAttr = parseText_ def [lt|+<?xml version="1.0" encoding="utf-8"?>+<root>+<a attr="content1"/>+<a attr="content2"/>+<a attr="content3"/>+</root>+|]++docSingleEmpty :: Document+docSingleEmpty = parseText_ def [lt|+<?xml version="1.0" encoding="utf-8"?>+<root>   <a/> </root> |]@@ -176,14 +208,38 @@ 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 "simple" $ do+        let parser = inElem "a" textFromDom+        specParserEq "docSimple" docSimple "content" parser+        specParserEq "docMultiple" docMultiple "content1" parser+      describe "deep" $ do+        let parser = inElem "a" $ inElem "b" textFromDom+        specParserEq "docDeep" docDeep "content" parser+        specParserEq "docDeepMultiple1" docDeepMultiple1 "content1" parser+        specParserEq "docDeepWithContent" docDeepWithContent "content" parser     describe "fails" $ do-      specParserFailed "docNone" docNone parser-      specParserFailed "docEmpty" docEmpty parser+      describe "simple" $ do+        let parser = inElem "a" textFromDom+        specParserFailed "docNone" docNone parser+        specParserFailed "docSingleEmpty" docSingleEmpty parser+      describe "deep" $ do+        let parser = inElem "a" $ inElem "b" textFromDom+        specParserFailedPath "docDeepMultiple2" docDeepMultiple2+          ["root", "a", "b"] parser+        -- should fail here because first tag "a" does not contains+        -- tag "b" which is expected by parser @inElem "b"@ +  describe "parseAttribute" $ do+    describe "succeeds" $ do+      specParserEq "docSimpleAttr" docSimpleAttr "content"+        $ inElem "a" $ parseAttribute "attr" Right+      let res = ["content1", "content2", "content3"]+      specParserEq "docMultipleAttr" docMultipleAttr res+        $ inElemAll "a" $ parseAttribute "attr" Right+    describe "fails" $ do+      specParserFailed "docNone" docNone $ parseAttribute "attr" Right+   describe "inElemAll" $ do     let parser = inElemAll "a" textFromDom     describe "succeeds" $ do@@ -192,7 +248,7 @@       specParserEq "docMultiple" docMultiple         ["content1", "content2", "content3"] parser     describe "fails" $ do-      specParserFailed "docEmpty" docEmpty parser+      specParserFailed "docSingleEmpty" docSingleEmpty parser    describe "inElemMay" $ do     let parser = inElemMay "a" textFromDom@@ -201,7 +257,7 @@       specParserEq "docSimple" docSimple (Just "content") parser       specParserEq "docMultiple" docMultiple (Just "content1") parser     describe "fails" $ do-      specParserFailed "docEmpty" docEmpty parser+      specParserFailed "docSingleEmpty" docSingleEmpty parser    describe "inElemNe" $ do     let parser = inElemNe "a" textFromDom@@ -211,7 +267,7 @@         (NE.fromList ["content1", "content2", "content3"]) parser     describe "fails" $ do       specParserFailed "docNone" docNone parser-      specParserFailed "docEmpty" docEmpty parser+      specParserFailed "docSingleEmpty" docSingleEmpty parser    describe "diveElem" $ do     describe "single element" $ do@@ -234,7 +290,7 @@     describe "mandatory element" $ do       let parser = inElem "a" $ ignoreEmpty textFromDom       describe "succeeds" $ do-        specParserEq "docEmpty" docEmpty Nothing parser+        specParserEq "docSingleEmpty" docSingleEmpty Nothing parser         specParserEq "docSimple" docSimple (Just "content") parser         specParserEq "docMultiple" docMultiple (Just "content1") parser       describe "fails" $ do@@ -243,7 +299,7 @@       let parser = fmap join $ inElemMay "a" $ ignoreEmpty textFromDom       describe "succeeds" $ do         specParserEq "docNone" docNone Nothing parser-        specParserEq "docEmpty" docEmpty Nothing parser+        specParserEq "docSingleEmpty" docSingleEmpty Nothing parser         specParserEq "docSimple" docSimple (Just "content") parser         specParserEq "docMultiple" docMultiple (Just "content1") parser @@ -271,14 +327,25 @@ structSpec :: Spec structSpec = do   describe "succeeds" $ do-    let-      result = TestStructure-                 { tsName = "name"-                 , tsInts = [1,2]-                 , tsBools = pure True }-    specParserEq "docStruct" docStruct result fromDom+    describe "dom structure" $ do+      let+        result = TestStructure+          { tsName = "name"+          , tsInts = [1,2]+          , tsBools = pure True }+      specParserEq "docStruct" docStruct result testStructureFromDom+    describe "attribute structure" $ do+      let+        result = TestStructure+          { tsName = "structure"+          , tsInts = [10]+          , tsBools = pure True }+      specParserEq "docAttrStruct" docAttrStruct result testStructureAttributes   describe "fails" $ do-    specParserFailed "docSimple" docSimple testStructureFromDom+    describe "dom structure" $ do+      specParserFailed "docSimple" docSimple testStructureFromDom+    describe "attr structure" $ do+      specParserFailed "docNone" docNone testStructureAttributes  main :: IO () main = hspec $ do