diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,4 @@ # CHANGELOG -## 0.0.1 -* First working version +## 0.1.0 +* Public release diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/dom-parser.cabal b/dom-parser.cabal --- a/dom-parser.cabal +++ b/dom-parser.cabal @@ -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 diff --git a/src/Text/XML/DOM/Parser.hs b/src/Text/XML/DOM/Parser.hs --- a/src/Text/XML/DOM/Parser.hs +++ b/src/Text/XML/DOM/Parser.hs @@ -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 diff --git a/src/Text/XML/DOM/Parser/Class.hs b/src/Text/XML/DOM/Parser/Class.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/DOM/Parser/Class.hs @@ -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 diff --git a/src/Text/XML/DOM/Parser/Combinators.hs b/src/Text/XML/DOM/Parser/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/DOM/Parser/Combinators.hs @@ -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) diff --git a/src/Text/XML/DOM/Parser/Types.hs b/src/Text/XML/DOM/Parser/Types.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/DOM/Parser/Types.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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| + name + 1 + 2 + t + +|] + +docNone :: Document +docNone = parseText_ def [lt| + + + +|] + +docEmpty :: Document +docEmpty = parseText_ def [lt| + + + + +|] + +docSimple :: Document +docSimple = parseText_ def [lt| + + + content + +|] + +docMultiple :: Document +docMultiple = parseText_ def [lt| + + + content1 + content2 + content3 + +|] + +docDeep :: Document +docDeep = parseText_ def [lt| + + + content + +|] + +docDeepWithContent :: Document +docDeepWithContent = parseText_ def [lt| + + + contentcontentcontent + +|] + +docDeepMultiple1 :: Document +docDeepMultiple1 = parseText_ def [lt| + + - content + content1 + content2 + + content3 + + - |] +|] -complexDoc :: Document -complexDoc = cleanDoc $ parseText_ def - [lt| +docDeepMultiple2 :: Document +docDeepMultiple2 = parseText_ def [lt| - - - - first - - - - - first - - - - - - - second - second - - - + + + content1 + + + content2 + content3 + - |] +|] 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