packages feed

xml-extractors (empty) → 0.2.0.0

raw patch · 9 files changed

+663/−0 lines, 9 filesdep +basedep +mtldep +safesetup-changed

Dependencies added: base, mtl, safe, transformers, xml

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Johan Holmquist++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.++    * 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.++    * Neither the name of Johan Holmquist nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++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.
+ README.md view
@@ -0,0 +1,15 @@+xml-extractor+=============++Simple wrapper over [xml](http://hackage.haskell.org/package/xml) to+extract data from parsed xml.++When parsing xml strings with `XML.Light` you get a list of+[Content](http://hackage.haskell.org/package/xml-1.3.13/docs/Text-XML-Light-Types.html#t:Content). Then+you can use functions from+[Text.XML.Light.Proc](http://hackage.haskell.org/package/xml-1.3.13/docs/Text-XML-Light-Proc.html)+to extract data from that. It is however kind of tricky to deal with+the potential errors -- we have a parsing problem again.++Instead of `Text.XML.Light.Proc` one can use this library. It simplifies+the process of extracting data from `Content` while dealing with errors.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Text/XML/Light/Extractors.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE NoMonomorphismRestriction, GeneralizedNewtypeDeriving #-}++-- | A library for making extraction of information from parsed XML easier.+--+-- = Example+--+-- Suppose you have an xml file of books like this:+--+-- > <?xml version="1.0"?>+-- > <library>+-- >   <book id="1" isbn="23234-1">+-- >     <author>John Doe</author>+-- >     <title>Some book</title>+-- >   </book>+-- >   <book id="2">+-- >     <author>You</author>+-- >     <title>The Great Event</title>+-- >   </book>+-- >   ...+-- > </library>+--+-- And a data type for a book:+--+-- > data Book = Book { bookdId       :: Int+-- >                  , isbn          :: Maybe String+-- >                  , author, title :: String+-- >                  }+--+-- You can parse the xml file into a generic tree structure using+-- 'Text.XML.Light.Input.parseXMLDoc', then extract information from+-- the tree using this library.+--+-- @+--    library = 'element' "library" $ 'children' $ 'many' book+--+--    book = 'element' "book" $ do+--             i <- 'attribAs' "id" 'Text.XML.Light.Extractors.Extra.integer'+--             s <- 'optional' ('attrib' "isbn")+--             'children' $ do+--               a <- 'element' "author" $ 'contents' $ 'text'+--               t <- 'element' "title" $ 'contents' $ 'text'+--               return $ Book { bookId = i, author = a, title = t, isbn = s }+--+--    extractLibrary :: 'XML.Element' -> 'Either' 'ExtractionErr' [Book]+--    extractLibrary = 'extractDocContents' library+-- @+--+-- /Note:/ The 'Control.Applicative' module contains some useful+-- combinators like 'optional', 'many' and '<|>'.+--+module Text.XML.Light.Extractors+  ( +  -- * Errors+    Path+  , Err(..)+  , ExtractionErr(..)+    +  -- * Element extraction+  , ElementExtractor+  , extractElement+  , attrib+  , attribAs+  , children+  , contents+  +  -- * Contents extraction+  , ContentsExtractor+  , extractContents+  , extractDocContents+  , element+  , text+  , textAs+  , eoc+  , only+  ) +where++import Control.Applicative+++import           Text.XML.Light.Types as XML+import qualified Text.XML.Light.Proc  as XML++import           Text.XML.Light.Extractors.Internal (ExtractionErr, Err, Path)+import qualified Text.XML.Light.Extractors.Internal as Internal+import           Text.XML.Light.Extractors.Internal.Result hiding (throwError, throwFatal)+import qualified Text.XML.Light.Extractors.Internal.Result as R++--------------------------------------------------------------------------------++newtype ElementExtractor a = ElementExtractor (Internal.ElementExtractor a)+ deriving (Applicative, Alternative, Functor, Monad)+++newtype ContentsExtractor a = ContentsExtractor (Internal.ContentsExtractor a)+ deriving (Applicative, Alternative, Functor, Monad)++--------------------------------------------------------------------------------+ +-- | @extractElement p element@ extracts @element@ with @p@.+extractElement :: ElementExtractor a -> XML.Element -> Either ExtractionErr a+extractElement (ElementExtractor p) elem = toEither $ Internal.runElementExtractor p elem []+++-- | @attrib name@ extracts the value of attribute @name@.+attrib :: String -> ElementExtractor String+attrib = ElementExtractor . Internal.attrib+++-- | @attribAs name f@ extracts the value of attribute @name@ and runs+-- it through a conversion/validation function.+attribAs :: String -> (String -> Either Err a) -> ElementExtractor a+attribAs name = ElementExtractor . (Internal.attribAs name)+++-- | @children p@ extract only child elements with @p@.+children :: ContentsExtractor a -> ElementExtractor a+children (ContentsExtractor p) = ElementExtractor (Internal.children p)+++-- | @contents p@ extract contents with @p@.+contents :: ContentsExtractor a -> ElementExtractor a+contents (ContentsExtractor p) = ElementExtractor (Internal.contents p)++--------------------------------------------------------------------------------++-- | @extractContents p contents@ extracts the contents with @p@.+extractContents :: ContentsExtractor a -> [XML.Content] -> Either ExtractionErr a+extractContents (ContentsExtractor p) cs =+  toEither (fst <$> Internal.runContentsExtractor p cs 1 [])+++-- | Using 'Text.XML.Light.Input.parseXMLDoc' produces a single+-- 'Element'. Such an element can be extracted using this function.+extractDocContents :: ContentsExtractor a -> XML.Element -> Either ExtractionErr a+extractDocContents p = extractContents p . return . Elem+++-- | @only p@ fails if there is more contents than extracted by @p@.+only :: ContentsExtractor a -> ContentsExtractor a+only p = p <* eoc+++-- | Succeeds only when there is no more content.+eoc :: ContentsExtractor ()+eoc = ContentsExtractor Internal.eoc+++-- | @element name p@ extracts a @name@ element with @p@.+element :: String -> ElementExtractor a -> ContentsExtractor a+element name (ElementExtractor a) = ContentsExtractor $ Internal.element name a+++-- | Extracts text.+text :: ContentsExtractor String+text = ContentsExtractor Internal.text+++-- | Extracts text applied to a conversion function.+textAs :: (String -> Either Err a) -> ContentsExtractor a+textAs = ContentsExtractor . Internal.textAs
+ src/Text/XML/Light/Extractors/Extra.hs view
@@ -0,0 +1,15 @@+module Text.XML.Light.Extractors.Extra where+++import Safe (readMay)+import Text.XML.Light.Extractors+++float :: (Floating a, Read a) => String -> Either Err a+float s = +  maybe (Left $ ErrMsg ("Expected float, found: " ++ show s)) return (readMay s)+++integer :: (Integral a, Read a) => String -> Either Err a+integer s = +  maybe (Left $ ErrMsg ("Expected integer, found: " ++ show s)) return (readMay s)
+ src/Text/XML/Light/Extractors/Internal.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE NoMonomorphismRestriction #-}++module Text.XML.Light.Extractors.Internal+  ( Path+  , Err(..)+  , ExtractionErr(..)+    +  -- * Element extraction+  , ElementExtractor+  , runElementExtractor+  , attrib+  , attribAs+  , children+  , contents+  +  -- * Contents extraction+  , ContentsExtractor+  , runContentsExtractor+  , element+  , text+  , textAs+  , eoc+  ) +where++import Control.Applicative++import Control.Monad.Identity+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State++import Data.Monoid++import           Text.XML.Light.Types as XML+import qualified Text.XML.Light.Proc  as XML++import           Text.XML.Light.Extractors.Internal.Result hiding (throwError, throwFatal)+import qualified Text.XML.Light.Extractors.Internal.Result as R++--------------------------------------------------------------------------------++elemName = qName . elName++qname name = QName name Nothing Nothing++--------------------------------------------------------------------------------++-- | Location for some content.+type Path = [String]+++addIdx :: Int -> Path -> Path+addIdx i p = show i : p++addElem :: XML.Element -> Path -> Path+++addElem e p = elemName e : p++addAttrib :: String -> Path -> Path+addAttrib a p = ('@':a) : p++--------------------------------------------------------------------------------++-- | Error with a context.+data ExtractionErr = ExtractionErr { err :: Err, context :: Path }+  deriving Show+++-- | Extraction errors.+data Err = ErrExpect+           { expected :: String      -- ^ expected content+           , found    :: XML.Content -- ^ found content+           } -- ^ Some expected content is missing+         | ErrAttr +           { expected  :: String       -- ^ expected attribute+           , atElement :: XML.Element  -- ^ element with missing attribute+           } -- ^ An expected attribute is missing+         | ErrEnd +           { found    :: XML.Content+           } -- ^ Expected end of contents+         | ErrNull+           { expected :: String  -- ^ expected content+           } -- ^ Unexpected end of contents+         | ErrMsg String+  deriving Show+++instance Error ExtractionErr where+  strMsg msg = ExtractionErr (ErrMsg msg) []+++throwError = lift . R.throwError++throwFatal = lift . R.throwFatal++--------------------------------------------------------------------------------++type ElementExtractor a = ReaderT (Path, XML.Element) (ResultT ExtractionErr Identity) a++runElementExtractor :: ElementExtractor a -> XML.Element -> Path -> Result ExtractionErr a+runElementExtractor p elem path = runIdentity $ runResultT $ runReaderT p (path,elem)++makeElementExtractor :: Result ExtractionErr a -> ElementExtractor a+makeElementExtractor (Fatal e) = throwFatal e+makeElementExtractor (Fail e)  = throwError e+makeElementExtractor (Ok a)    = return a+++attrib :: String -> ElementExtractor String+attrib name = attribAs name return+++attribAs :: String -- ^ name of attribute to extract+         -> (String -> Either Err a)+         -> ElementExtractor a+attribAs name f = do+  (path,x) <- ask+  let path' = addAttrib name path+  case XML.lookupAttr (qname name) (elAttribs x) of+    Nothing -> throwError $ ExtractionErr (ErrAttr name x) path+    Just s  ->+      case f s of+        Left e  -> throwFatal $ ExtractionErr e path'+        Right a -> return a+++contents :: ContentsExtractor a -> ElementExtractor a+contents p = do+  (path,x) <- ask+  let r = runContentsExtractor p (elContent x) 1 path+  makeElementExtractor $ fmap fst r+++children :: ContentsExtractor a -> ElementExtractor a+children p = do+  (path,x) <- ask+  let r = runContentsExtractor p (map XML.Elem $ XML.elChildren x) 1 path+  makeElementExtractor $ fmap fst r+++-- | Lift a string function to an element extractor.+liftToElement :: (String -> Either Err a) -> String -> ElementExtractor a+liftToElement f s = do+  (path,x) <- ask+  case f s of+    Left e   -> throwError (ExtractionErr e path)+    Right a  -> return a+  ++--------------------------------------------------------------------------------++type Ctx = (Path, Int, [XML.Content])++type ContentsExtractor a = StateT Ctx (ResultT ExtractionErr Identity) a++runContentsExtractor :: ContentsExtractor a -> [Content] -> Int -> Path -> Result ExtractionErr (a, Ctx)+runContentsExtractor p contents i path = +  runIdentity $ runResultT $ runStateT p (path, i, contents)+++first :: String -> (Content -> Path -> Result ExtractionErr a) -> ContentsExtractor a+first expect f = do+  (path,i,xs) <- get+  case xs of+    []     -> throwError $ ExtractionErr (ErrNull expect) path+    (x:xs) -> do+      case f x (addIdx i path) of+        Fatal e -> throwFatal e+        Fail  e -> throwError e+        Ok    a -> do+          put (path,i+1,xs)+          return a+++eoc :: ContentsExtractor ()+eoc = do+  (path,_,xs) <- get+  case xs of+    []    -> return ()+    (x:_) -> throwError (ExtractionErr (ErrEnd x) path)+++element :: String -> ElementExtractor a -> ContentsExtractor a+element name p = first expect go+  where+    go c@(Elem x) path+      | elemName x == name = escalate $ runElementExtractor p x (addElem x path)+    go c          path     = Fail (ExtractionErr (ErrExpect expect c) path)++    expect = "element " ++ show name+++textAs :: (String -> Either Err a) -> ContentsExtractor a+textAs f = first "text" go +  where+    go (Text x) path =+      case f (cdData x) of+        Left e  -> Fatal $ ExtractionErr e path+        Right s -> return s+    go c path = Fail $ ExtractionErr (ErrExpect "text" c) path+++text = textAs return
+ src/Text/XML/Light/Extractors/Internal/Result.hs view
@@ -0,0 +1,157 @@+module Text.XML.Light.Extractors.Internal.Result + ( Result(..)+ , toEither+ , escalate++ , ResultT+ , runResultT+ , throwError+ , throwFatal+ , mapResult++ , module Control.Monad.Trans.Error+ , Control.Monad.Trans.Class.lift+ )+where++import Control.Applicative+import Control.Monad+import Control.Monad.Trans.Error (Error, noMsg, strMsg)+import Control.Monad.Trans.Class+++-- | 'Result' is like 'Either' but with two error states, 'Fail' and 'Fatal'.+--+-- 'Fail' is precisely analogous to 'Left' while 'Fatal' has short cut+-- semantics for 'Alternative'.+--+-- The idea is that 'Fatal' errors cannot be circumvented by '<|>' etc.+data Result e a = Fatal e+                | Fail e+                | Ok a+  deriving Show+++instance Functor (Result e) where+  fmap f (Ok a)    = Ok (f a)+  fmap _ (Fail e)  = Fail e+  fmap _ (Fatal e) = Fatal e+++instance Applicative (Result e) where+  pure = Ok+  +  Ok f    <*> a = fmap f a+  Fatal e <*> _ = Fatal e+  Fail e  <*> _ = Fail e+++instance Error e => Alternative (Result e) where+  empty = Fail noMsg++  Fatal e <|> _ = Fatal e+  Fail _  <|> x = x+  m       <|> _ = m+++instance Monad (Result e) where+  return = pure++  Fatal e >>= _ = Fatal e+  Fail e  >>= _ = Fail e+  Ok a    >>= k = k a+++-- | Maps 'Fail' to 'Fatal'.+escalate :: Result e a -> Result e a+escalate (Fail e) = Fatal e+escalate x        = x+++-- | Maps 'Fail' and 'Fatal' to 'Left'.+toEither (Fatal e) = Left e+toEither (Fail e)  = Left e+toEither (Ok a)    = Right a++--------------------------------------------------------------------------------++newtype ResultT e m a = ResultT { runResultT :: m (Result e a) }+++instance Functor m => Functor (ResultT e m) where+  fmap f = ResultT . fmap (fmap f) . runResultT+++instance (Functor m, Monad m) => Applicative (ResultT e m) where+  pure a = ResultT $ return (Ok a)++  f <*> v = ResultT $ do+              mf <- runResultT f+              case mf of+                Fatal e -> return (Fatal e)+                Fail  e -> return (Fail e)+                Ok   f' -> do+                   mv <- runResultT v+                   return (fmap f' mv)+++instance (Error e, Monad m) => MonadPlus (ResultT e m) where+  mzero = ResultT $ return (Fail noMsg)+  +  mplus x y = ResultT $ do+                l <- runResultT x+                case l of+                  Fatal e -> return (Fatal e)+                  Fail  _ -> runResultT y+                  Ok    a -> return (Ok a)+++instance (Monad m, Error e) => Monad (ResultT e m) where+  return = ResultT . return . Ok++  m >>= k = ResultT $ do+              r <- runResultT m+              case r of+                Fatal e -> return (Fatal e)+                Fail  e -> return (Fail e)+                Ok    a -> runResultT (k a)++  fail msg = ResultT $ return $ Fail (strMsg msg)+++instance (Functor m, Monad m, Error e) => Alternative (ResultT e m) where+  empty = mzero+  (<|>) = mplus+++instance (Error e) => MonadTrans (ResultT e) where+  lift m = ResultT $ do+             a <- m+             return (Ok a)+++throwError :: (Error e, Monad m) => e -> ResultT e m a+throwError = ResultT . return . Fail+++throwFatal :: (Error e, Monad m) => e -> ResultT e m a+throwFatal = ResultT . return . Fatal+++mapResult+  :: (Functor m, Monad m) =>+     (Result e1 a1 -> Result e a) -> ResultT e1 m a1 -> ResultT e m a+mapResult f = ResultT . fmap f . runResultT++--------------------------------------------------------------------------------++testX :: ResultT String IO Int+testX = lift (print "x") >> return 1++testY :: ResultT String IO Int+testY = lift (print "error") >> throwError "error"++testZ :: ResultT String IO Int+testZ = lift (print "fatal") >> throwFatal "fatal"++--------------------------------------------------------------------------------
+ src/Text/XML/Light/Extractors/ShowErr.hs view
@@ -0,0 +1,29 @@+module Text.XML.Light.Extractors.ShowErr where++import Data.List++import           Text.XML.Light.Types+import qualified Text.XML.Light.Output as XML+import           Text.XML.Light.Extractors.Internal (ExtractionErr(..), Err(..), Path)+++showExtractionErr :: ExtractionErr -> String+showExtractionErr (ExtractionErr e path) = showErr e ++ "\nin " ++ showPath path++showPath :: Path -> String+showPath = intercalate "/" . reverse+++showErr (ErrExpect expect found) =+  unwords ["Expected", expect, "found", take 60 $ XML.showContent found]++showErr (ErrAttr expect parent) =+  unwords ["Missing attribute", show expect, "of", qName $ elName parent]++showErr (ErrMsg msg) = msg++showErr (ErrNull expected) = +  unwords ["Expected", expected]++showErr (ErrEnd found) =+  unwords ["Unexpected:", take 60 $ XML.showContent found]
+ xml-extractors.cabal view
@@ -0,0 +1,50 @@+name:                xml-extractors+version:             0.2.0.0+synopsis:            Simple wrapper over xml (Text.XML.Light) to extract data from parsed xml+description:+  This is a library to make it easier to extract data from parsed xml.+  .+  See the 'Text.XML.Light.Extractors' module for an example.+  .+  = Motivation+  .+  The xml package provides functions to parse and get information+  from xml data. You can parse an xml string into a generic xml tree+  representation. Then to extract information from that tree and into+  you own data types you can use this library.+  .+  If there is an error during extraction (expected information is+  absent or wrong), you will get an error value with position information.+  .+  = Some limitations+  .+    * Only handles unqualified names, so far.+  .+    * No column or line number reference in error values.+ +homepage:            https://github.com/holmisen/xml-extractors+license:             BSD3+license-file:        LICENSE+author:              Johan Holmquist+maintainer:          holmisen@gmail.com+-- copyright:           +category:            Text, XML+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++library+  exposed-modules:     Text.XML.Light.Extractors, +                       Text.XML.Light.Extractors.Internal,+                       Text.XML.Light.Extractors.Internal.Result,+                       Text.XML.Light.Extractors.Extra,+                       Text.XML.Light.Extractors.ShowErr+  -- other-modules:       +  other-extensions:    NoMonomorphismRestriction+  build-depends:       base >=4.6 && <4.8,+                       xml >=1.3 && <1.4,+                       mtl >=2.1 && <2.2,+                       transformers >=0.3 && <0.4,+                       safe >=0.3 && <0.4+  hs-source-dirs:      src+  default-language:    Haskell2010