xml-conduit-decode (empty) → 1.0.0.0
raw patch · 9 files changed
+910/−0 lines, 9 filesdep +basedep +bifunctorsdep +data-defaultsetup-changed
Dependencies added: base, bifunctors, data-default, lens, semigroups, tasty, tasty-hunit, text, time, xml-conduit, xml-conduit-decode, xml-types
Files
- LICENSE +22/−0
- Setup.hs +2/−0
- src/Text/XML/Decode.hs +127/−0
- src/Text/XML/Decode/DecodeCursor.hs +205/−0
- src/Text/XML/Decode/HCursor.hs +252/−0
- src/Text/XML/Decode/Parsers.hs +64/−0
- src/Text/XML/Decode/Time.hs +27/−0
- tests/Main.hs +162/−0
- xml-conduit-decode.cabal +49/−0
+ LICENSE view
@@ -0,0 +1,22 @@+The MIT License (MIT)++Copyright (c) 2015 Ben Kolera++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:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++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.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Text/XML/Decode.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{- |+Module : Text.XML.Decode+Description : Provides a Cursor based XML decoder that gives nice error messages+Copyright : (c) Ben Kolera+License : MIT++Maintainer : Ben Kolera+Stability : experimental++This library extends the functionality of 'Text.XML.Cursor' to allow you to+accumulate history as you traverse the structure. This leads to greater context+about why your decoder failed when it invariably does.++Here is an example of a decoder:++@+data BookCategory+ = Haskell+ | Scala+ | Programming+ | FunctionalProgramming+ deriving (Eq,Show)++bookCategoryFromText :: Text -> Maybe BookCategory+bookCategoryFromText "Haskell" = Just Haskell+bookCategoryFromText "Scala" = Just Scala+bookCategoryFromText "Programming" = Just Programming+bookCategoryFromText "Functional Programming" = Just FunctionalProgramming+bookCategoryFromText _ = Nothing+++data LibrarySection+ = Fiction Text -- Fiction by author first letter(s)+ | NonFiction Double -- Dewey decimal number+ deriving (Eq,Show)+makePrisms ''LibrarySection++data Book = Book+ { _bookId :: Integer+ , _bookName :: Text+ , _bookSection :: LibrarySection+ , _bookPublished :: Day+ , _bookLastBorrowed :: Maybe UTCTime+ , _bookCategories :: [BookCategory]+ } deriving (Eq,Show)+makeLenses ''Book++data Library = Library+ { _books :: [Book]+ } deriving (Eq,Show)+makeLenses ''Library++instance DecodeCursor BookCategory where+ decode = parseCursor (parseMaybe "BookCategory" bookCategoryFromText)++instance DecodeCursor LibrarySection where+ decode = decodeChoice+ [ choice (laxElement "fiction") decodeFiction+ , choice (laxElement "non_fiction") decodeNonFiction+ ]+ where+ decodeFiction c = Fiction <$> parseCursor parseText c+ decodeNonFiction c = NonFiction <$> parseCursor parseDouble c++instance DecodeCursor Book where+ decode c = Book+ <$> decodeAttr "id" parseInteger c+ <*> decodeSingle (c %/ laxElement "name")+ <*> decodeSingle (c %/ laxElement "section")+ <*> (decodeSingle (c %/ laxElement "published") <&> toDay)+ <*> (decodeMay (c %/ laxElement "lastBorrowed") <&> fmap toUtcT)+ <*> decodeMany (c %/ laxElement "category")++instance DecodeCursor Library where+ decode c = Library+ <$> decodeMany ( c %/ laxElement "book" )+@++If you tried to decode the following XML with a bad value for the section:++@+<library>+ <book id="1">+ <name>Learn you a haskell for great good!</name>+ <section>+ <reference>5.1</reference>+ </section>+ <published>2011-04-21</published>+ <lastBorrowed>2015-01-05T16:30:00Z</lastBorrowed>+ <category>Programming</category>+ <category>Haskell</category>+ <category>Functional Programming</category>+ </book>+</library>+@++Then you'd get an error that looks like this:++@+ Left (+ "Choices Exhausted"+ , [ MoveAxis Child , LaxElement "book"+ , MoveAxis Child , LaxElement "section"+ , Choice+ [ [ MoveAxis Child , LaxElement "fiction" ]+ , [ MoveAxis Child , LaxElement "non_fiction" ]]+ Nothing+ ])+@++Checkout the tests for more examples!++-}++module Text.XML.Decode+ ( module Text.XML.Decode.DecodeCursor+ , module Text.XML.Decode.HCursor+ , module Text.XML.Decode.Parsers+ , module Text.XML.Decode.Time+ ) where++import Text.XML.Decode.DecodeCursor+import Text.XML.Decode.HCursor+import Text.XML.Decode.Parsers+import Text.XML.Decode.Time
+ src/Text/XML/Decode/DecodeCursor.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{- |+Module : Text.XML.Decode.DecodeCursor+Description : Decode combinators to parse the contents of a HCursor+Copyright : (c) Ben Kolera+License : MIT++Maintainer : Ben Kolera+Stability : experimental++These functions allow you to pull haskell values out of a HCursor.++The idea is that you use the HCursor combinators to get where you need to in+the XML, and something in this file allows you to parse the XML into values.++Because of how the underlaying Text.XML.Cursors work, these functions have the+following oddities:++ * The cursor could actually be at 0 or many elements, so the 'decodeMay',+ 'decodeSingle','decodeMany','decodeNel' functions allow you to express how many+ elements you want to decode. 'DecodeCursor' powers these functions.+ * The cursor has no concept of being at an attribute, so we need the hack+ of 'decodeAttrMay','decodeAttr' to pull out a named attribute from the positions+ that the cursor is in.+ * Choices are weird and our only spot where we have multiple different elements+ at a Cursor and need to disambiguate them by the element name. 'DecodeChoice'+ pairs element names with a decoder that will decode the element into a sum+ type constructor. See the 'decodeChoice' function and the 'choice' constructor.+-}+module Text.XML.Decode.DecodeCursor+ ( DecodeResult+ , DecodeCursor+ , decode+ , decodeMay+ , decodeSingle+ , decodeDefault+ , decodeMany+ , decodeNel+ , decodeDocument+ , decodeAttr+ , ChoiceDecoder+ , choice+ , decodeChoice+ , decodeAttrMay+ , parseCursor+ , cursorContents+ ) where++import Control.Lens+import Data.Bifunctor (first)+import Data.Foldable (find, fold)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NEL+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import Text.XML (Document)+import qualified Text.XML.Cursor as C++import Text.XML.Decode.Parsers+import Text.XML.Decode.Time+import Text.XML.Decode.HCursor++-- | Gives you a the result of the decoding or a text description of the error+-- and a history of cursor movements prior to the error.+type DecodeResult a = Either (Text,CursorHistory) a++nelCursor :: HCursor -> DecodeResult (NonEmpty HCursor)+nelCursor = foldCursor f w+ where+ f = Left . ("Tried to convert failed cursor to NEL",)+ w cs h = Right $ fmap (\ c -> HCursor [c] h) cs++cursorAttribute :: Text -> HCursor -> CursorResult Text+cursorAttribute n = foldCursor f w+ where+ f _ = Right $ "" :| []+ w cs _ = Right $ fmap (fold . C.laxAttribute n) cs++-- | Grabs the concatenated text of all elements of a cursor.+cursorContents+ :: HCursor -- ^ The cursor to extract all text nodes from+ -> CursorResult Text -- ^ Left if the cursor was failed, else all text nodes concatenated into a single text+cursorContents = foldCursor f w+ where+ f h = Left ("Tried to decode a failed cursor",h)+ w cs _ = Right . fmap (T.concat . (C.$// C.content)) $ cs++-- | DecodeCursor is the crux of pulling things out of XML in a reusable way.+-- You'll want to implement it for any data type that you wish to construct+-- out of a XML element.+class DecodeCursor a where+ -- | You wont call this outside of here. Call 'decodeSingle' instead+ decode :: HCursor -> DecodeResult a++-- | Decodes zero or one results from the cursor.+decodeMay :: DecodeCursor a => HCursor -> DecodeResult (Maybe a)+decodeMay = foldCursor (const (Right Nothing)) w+ where+ w cs h = Just <$> decode (HCursor [NEL.head cs] h)++-- | Decodes a single result from the Cursor. Errors if the cursor is empty.+decodeSingle :: DecodeCursor a => HCursor -> DecodeResult a+decodeSingle = (decode . NEL.head =<<) . nelCursor++-- | Decodes a result from the cursor, or provides the default if the cursor is empty.+decodeDefault :: DecodeCursor a => a -> HCursor -> DecodeResult a+decodeDefault a = fmap (fromMaybe a) . decodeMay++-- | Decodes 0 or more results from the cursor.+decodeMany :: DecodeCursor a => HCursor -> DecodeResult [a]+decodeMany = foldCursor (const $ return []) w+ where+ w cs h = NEL.toList <$> traverse (\ c -> decode $ HCursor [c] h) cs++-- | Decodes 1 or more results. Fails if the cursor is empty.+decodeNel :: DecodeCursor a => HCursor -> DecodeResult (NonEmpty a)+decodeNel hc = nelCursor hc >>= traverse decode++-- | Takes an entire document, an a cursor shift to shift from the top of the document+-- to where you need to start parsing.+decodeDocument :: DecodeCursor a+ => (HCursor -> HCursor)+ -> Document+ -> Either (Text,CursorHistory,Document) a+decodeDocument s d = first (\ (t,h) -> (t,h,d)) . decode . s . fromDocument $ d++-- | Grab an attribute from the element focused by the cursor+decodeAttr+ :: Text -- ^ The attribute name+ -> (Text -> Either Text a) -- ^ A parser from Text to either an error or the result+ -> HCursor -- ^ The cursor to parse from+ -> DecodeResult a+decodeAttr n f hc =+ (first ((,hc ^. history) . errorMessage) . f . NEL.head =<<)+ . cursorAttribute n+ $ hc+ where+ errorMessage pe = T.concat ["Failed to get attr (",n,"): ",pe]++-- | Optionally grab an attribute from the cursor.+decodeAttrMay :: Text -> (Text -> Either Text a) -> HCursor -> DecodeResult (Maybe a)+decodeAttrMay n f = decodeAttr n parse+ where+ parse "" = Right Nothing+ parse t = Just <$> f t++-- | Describes how to navigate to the choice element and then decode it.+data ChoiceDecoder a = ChoiceDecoder+ { _choiceDecoderShift :: Shift+ , _choiceDecoderDecode :: HCursor -> DecodeResult a+ }+makeLenses ''ChoiceDecoder++-- | Constructs a ChoiceDecoder+choice+ :: Shift -- ^ Given a shift to the element (e.g. laxElement "foo")+ -> (HCursor -> DecodeResult a) -- ^ And a parser+ -> ChoiceDecoder a+choice = ChoiceDecoder++-- | Given a choice of elements, decode the first where the shift succeeds.+--+-- Using it usually takes this shape:+--+-- @+-- instance DecodeCursor LibrarySection where+-- decode = decodeChoice+-- [ choice (laxElement "fiction") decodeFiction+-- , choice (laxElement "non_fiction") decodeNonFiction+-- ]+-- where+-- decodeFiction c = Fiction <$> parseCursor parseText c+-- decodeNonFiction c = NonFiction <$> parseCursor parseDouble c+-- @+--+decodeChoice :: [ChoiceDecoder a] -> HCursor -> DecodeResult a+decodeChoice cds (HCursor c h) =+ withResHistory (h++)+ . maybe noMatch doDecode+ . find matched+ $ shifted+ where+ noHistory = HCursor c []+ shifted = fmap (\cd -> (cd,noHistory %/ (cd^.choiceDecoderShift))) cds+ matched = successfulCursor . snd+ unMatched = fmap (^._2.history) . filter (not . matched) $ shifted+ noMatch = Left ("Choices Exhausted",thisOp Nothing)+ doDecode (cd,bh) = withResHistory (thisOp . Just) . (cd^.choiceDecoderDecode) $ bh+ thisOp hh = [Choice unMatched hh]+ withResHistory f = first (& over _2 f)++-- | Helper function for parsing the text of the cursor+parseCursor :: (Text -> Either Text a) -> HCursor -> DecodeResult a+parseCursor f hc = (first (,hc ^. history) . f . fold =<<) . cursorContents $ hc++instance DecodeCursor Text where decode = fmap fold . cursorContents+instance DecodeCursor Int where decode = parseCursor parseInt+instance DecodeCursor Integer where decode = parseCursor parseInteger+instance DecodeCursor Double where decode = parseCursor parseDouble+instance DecodeCursor Bool where decode = parseCursor parseBool+instance DecodeCursor IsoUTCTime where decode = parseCursor parseIsoUtcTime+instance DecodeCursor IsoDay where decode = parseCursor parseIsoDay
+ src/Text/XML/Decode/HCursor.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE TemplateHaskell #-}+{- |+Module : Text.XML.Decode.HCursor+Description : Traverses around a Cursor accumulating history+Copyright : (c) Ben Kolera+License : MIT++Maintainer : Ben Kolera+Stability : experimental++The big issue with using a plain 'Text.XML.Cursor' is that all you get when you+fail to parse what you were after is an Empty list of cursors and no idea how+you got there.++An HCursor, however, only allows you to traverse it using the combinators in this+file, and each one of these combinators accumulates `CursorHistory` in the HCursor+describing each navigation operation, so that if you ever get to a position where+you have an empty HCursor (i.e. the elements you were looking for didn't exist)+then you can use that history to describe where you went wrong in an error+message.++There is a general pattern to the combinators in this file:++Prefixes:++ * % apply a shift to a HCursor+ * $ apply a shift to a Cursor+ * & apply a shift to another shift (composes them)++Suffixes:++ * / Applies the shift to the children of the current foci+ * // Applies the shift to all descendants of the current foci++-}+module Text.XML.Decode.HCursor+ ( Shift+ , shift+ , HCursor(..)+ , CursorOp(..)+ , CursorAxis(..)+ , CursorResult+ , CursorHistory+ , Predicate(..)+ , foldCursor+ , fromCursor+ , fromDocument+ , failedCursor+ , successfulCursor+ , withHistory+ -- Lenses / Prisms+ , cursors+ , history+ , _Child+ , _Descendant+ , _Backtrack+ , _BacktrackSucceed+ , _GenericOp+ , _MoveAxis+ , _LaxElement+ , _FailedCompose+ , predFun+ , predDesc+ -- Shifts+ , laxElement+ , filterPred+ , shiftGeneric+ , (|||)+ , (***)+ , (%/)+ , (%//)+ , ($/)+ , ($//)+ , (&/)+ , (&//)+ ) where++import Control.Lens (makeLenses, makePrisms, over, to, (&),+ (^.))+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NEL+import Data.Text (Text)+import qualified Text.XML as X+import qualified Text.XML.Cursor as C++-- | These describe the axis that we can move from one set of elements to another.+-- Note, these MoveAxis operations are the only CursorOps that actually "move"+-- the cursor and replace the current foci with another set of possibilities.+--+-- Every other operation is actually a filtering operation of the foci.+data CursorAxis+ = Child -- ^ To just the immediate children of our elements+ | Descendant -- ^ To all descendants of the current elements+ deriving (Show,Eq)+makePrisms ''CursorAxis++type CursorHistory = [CursorOp]++-- | Describes the operations that got an HCursor into its state+data CursorOp =+ -- | We had a choice, determined by the shifts. The shifts that we failed+ -- to match are recorded and our potential success is too.+ Choice { _notMatched :: [CursorHistory] , _matched :: Maybe CursorHistory }+ -- | This is brought by the '|||' operator which backtracks to the next+ -- cursor if the first one fails+ | Backtrack { _failed :: CursorHistory , _new :: CursorHistory }+ -- | When the first choice of a backtrack succeeds+ | BacktrackSucceed CursorHistory+ -- | If you need to cheat and create your own Op with a text description+ | GenericOp Text+ -- | Move the cursor from its current foci to a new set of foci based on the axis+ | MoveAxis CursorAxis+ -- | Filter the current foci based on element name (case insensive, namespace free)+ | LaxElement Text+ -- | Filter the current foci based on a predicate (described by a string)+ | FilterPredicate Text+ -- | We tried to do a Shift onto a HCursor that was empty.+ | FailedCompose+ deriving (Show,Eq)+makePrisms ''CursorOp++-- | An HCursor carries around the elements of the XML in focus (the cursors)+-- and the history as to how we got these elements in focus.+data HCursor = HCursor+ { _cursors :: [C.Cursor]+ , _history :: CursorHistory+ } deriving (Show)+makeLenses ''HCursor++-- | A shift moves the HCursor foci to another set of foci, collection cursor+-- history in the new HCursor. If the shift could not find any elements from+-- this movement, the cursor will be empty.+data Shift = Shift { runShift :: C.Cursor -> HCursor }++-- | Construct a shift given a `Cursor` movement and a description of the movement+shift :: (C.Cursor -> [C.Cursor]) -> CursorOp -> Shift+shift f o = Shift (\ c -> HCursor (f c) [o])++-- | Tests to see whether this cursor still has foci to traverse+successfulCursor :: HCursor -> Bool+successfulCursor = foldCursor (const False) (const . const $ True)++-- | Tests to see if this cursor has no foci left (has failed)+failedCursor :: HCursor -> Bool+failedCursor = not . successfulCursor++-- | Modify the history of a cursor+withHistory :: (CursorHistory -> CursorHistory) -> HCursor -> HCursor+withHistory f = (& over history f)++bindCursor :: (C.Cursor -> HCursor) -> HCursor -> HCursor+bindCursor f = foldCursor aFail aWin+ where+ aFail h = HCursor [] (h ++ [FailedCompose])+ aWin cs h = let+ cs' = fmap f cs+ ws = NEL.filter successfulCursor cs'+ in case ws of+ [] -> HCursor [] (h ++ (cs' ^. to NEL.head . history))+ (x:_) -> HCursor (ws >>= (^. cursors)) (h ++ x ^. history)++-- | Fold on whether the cursor is failed+foldCursor+ :: (CursorHistory -> a) -- ^ Failure: Gives the history leading to this failure+ -> (NonEmpty C.Cursor -> CursorHistory -> a) -- ^ The foci and history+ -> HCursor+ -> a+foldCursor f _ (HCursor [] h ) = f h+foldCursor _ w (HCursor (x:xs) h ) = w (x :| xs) h+++-- | Tries the first shift, and backtracks to try the second if the first fails+(|||) :: Shift -> Shift -> Shift+a ||| b = Shift step+ where+ step c = foldCursor (aFail c) aWin . runShift a $ c+ aFail c ah = withHistory (\ bh -> [Backtrack ah bh]) . runShift b $ c+ aWin cs ah = HCursor (NEL.toList cs) [BacktrackSucceed ah]++(>=>) :: Shift -> Shift -> Shift+a >=> b = Shift $ bindCursor (runShift b) . runShift a++-- | Repeat a shift n times+(***) :: Shift -> Int -> Shift+s *** 0 = s+s *** n = s >=> (s *** (n - 1))++-- | Constructs a Generic Cheat Text shift operation+shiftGeneric :: Text -> (C.Cursor -> [C.Cursor]) -> Shift+shiftGeneric n f = shift f $ GenericOp n++-- | Apply this shift to the children of the current foci+(%/) :: HCursor -> Shift -> HCursor+hc %/ s = bindCursor (runShift (shiftAxis Child >=> s)) hc++-- | Apply this shift to all descendants of the current foci+(%//) :: HCursor -> Shift -> HCursor+hc %// s = bindCursor (runShift (shiftAxis Descendant >=> s)) hc++-- | Compose a shift to another shift, apply the right to children foci following the first shift+(&/) :: Shift -> Shift -> Shift+a &/ b = a >=> shiftAxis Child >=> b++-- | Compose a shift to another shift, apply the right all descendant foci following the first shift+(&//) :: Shift -> Shift -> Shift+a &// b = a >=> shiftAxis Descendant >=> b++-- | Apply a shift to children elements of a raw `Cursor`+($/) :: C.Cursor -> Shift -> HCursor+c $/ s = runShift (shiftAxis Child >=> s) c++-- | Apply a shift to descendant elements of a raw `Cursor`+($//) :: C.Cursor -> Shift -> HCursor+c $// s = runShift (shiftAxis Descendant >=> s) c+++infixr 1 &/+infixr 1 &//+infixr 1 $/+infixr 1 $//+infixr 1 %/+infixr 1 %//++shiftAxis :: CursorAxis -> Shift+shiftAxis ca = shift (C.$| axis) $ MoveAxis ca+ where+ axis = case ca of+ Child -> C.child+ Descendant -> C.descendant++-- | Filter foci based on element name, ignoring case or namespaces+laxElement :: Text -> Shift+laxElement n = shift (C.$| C.laxElement n) $ LaxElement n++-- | A node filtering function with a textual description+data Predicate = Predicate+ { _predDesc :: Text+ , _predFun :: X.Node -> Bool+ }+makeLenses ''Predicate++-- | Filter foci based on the predicate+filterPred :: Predicate -> Shift+filterPred (Predicate d f) = shift (C.$| C.checkNode f) $ FilterPredicate d++type CursorResult a = Either (Text,CursorHistory) (NonEmpty a)++fromCursor :: C.Cursor -> HCursor+fromCursor c = HCursor [c] []++fromDocument :: X.Document -> HCursor+fromDocument = fromCursor . C.fromDocument
+ src/Text/XML/Decode/Parsers.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings #-}+{- |+Module : Text.XML.Decode.Parsers+Description : Helper functions from Text -> Either Text a+Copyright : (c) Ben Kolera+License : MIT++Maintainer : Ben Kolera+Stability : experimental++-}+module Text.XML.Decode.Parsers+ ( parseText+ , parseMaybe+ , parseInt+ , parseInteger+ , parseDouble+ , parseBool+ , parseXmlTime+ , parseIsoUtcTime+ , parseIsoDay+ ) where++import Data.Foldable (fold)+import Data.Text (Text, toLower, unpack)+import Data.Time (ParseTime, parseTimeM, defaultTimeLocale)+import Text.Read (readMaybe)++import Text.Read (readMaybe)+import Text.XML.Decode.Time++parseText :: Text -> Either Text Text+parseText = Right++parseMaybe :: Text -> (Text -> Maybe a) -> Text -> Either Text a+parseMaybe desc f t = maybe (Left (fold ["'",t, "' was not ",desc])) Right (f t)++parseInt :: Text -> Either Text Int+parseInt = parseMaybe "an int" (readMaybe . unpack)++parseInteger :: Text -> Either Text Integer+parseInteger = parseMaybe "an integer" (readMaybe . unpack)++parseDouble :: Text -> Either Text Double+parseDouble = parseMaybe "a double" (readMaybe . unpack)++parseBool :: Text -> Either Text Bool+parseBool = parseMaybe "a bool" parseBool' . toLower+ where+ parseBool' "true" = Just True+ parseBool' "false" = Just False+ parseBool' _ = Nothing+++parseXmlTime :: ParseTime a => Text -> String -> Text -> Either Text a+parseXmlTime desc format =+ parseMaybe desc (parseTimeM True defaultTimeLocale format . unpack)++parseIsoUtcTime :: Text -> Either Text IsoUTCTime+parseIsoUtcTime =+ fmap IsoUTCTime . parseXmlTime "UTCTime" isoUTCTimeFormat++parseIsoDay :: Text -> Either Text IsoDay+parseIsoDay = fmap IsoDay . parseXmlTime "UTCDay" isoDayFormat
+ src/Text/XML/Decode/Time.hs view
@@ -0,0 +1,27 @@+{- |+Module : Text.XML.Decode.Time+Description : Newtypes for Data.Time parsing+Copyright : (c) Ben Kolera+License : MIT++Maintainer : Ben Kolera+Stability : experimental++Some newtypes that denote Days and UTCTimes to be parsed in ISO8601 format++-}+module Text.XML.Decode.Time+ ( IsoUTCTime(..)+ , IsoDay(..)+ , isoUTCTimeFormat+ , isoDayFormat+ ) where++import Data.Time (Day, UTCTime)++newtype IsoUTCTime = IsoUTCTime { toUtcT :: UTCTime }+newtype IsoDay = IsoDay { toDay :: Day }++isoUTCTimeFormat,isoDayFormat :: String+isoUTCTimeFormat = "%FT%TZ"+isoDayFormat = "%F"
+ tests/Main.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module Main where++import Prelude (Double, Eq, IO, Integer, Show)++import Control.Applicative ((<$>), (<*>))+import Control.Category ((.))+import Control.Lens++import Data.Default (def)+import Data.Either (Either (..))+import Data.Function (($))+import Data.Functor (fmap)+import Data.Maybe (Maybe (..))+import Data.Monoid ((<>))+import Data.Text+import Data.Time++import Test.Tasty+import Test.Tasty.HUnit+import Text.XML (Document, readFile)++import Text.XML.Decode++data BookCategory+ = Haskell+ | Scala+ | Programming+ | FunctionalProgramming+ deriving (Eq,Show)++bookCategoryFromText :: Text -> Maybe BookCategory+bookCategoryFromText "Haskell" = Just Haskell+bookCategoryFromText "Scala" = Just Scala+bookCategoryFromText "Programming" = Just Programming+bookCategoryFromText "Functional Programming" = Just FunctionalProgramming+bookCategoryFromText _ = Nothing+++data LibrarySection+ = Fiction Text -- Fiction by author first letter(s)+ | NonFiction Double -- Dewey decimal number+ deriving (Eq,Show)+makePrisms ''LibrarySection++data Book = Book+ { _bookId :: Integer+ , _bookName :: Text+ , _bookSection :: LibrarySection+ , _bookPublished :: Day+ , _bookLastBorrowed :: Maybe UTCTime+ , _bookCategories :: [BookCategory]+ } deriving (Eq,Show)+makeLenses ''Book++data Library = Library+ { _books :: [Book]+ } deriving (Eq,Show)+makeLenses ''Library++instance DecodeCursor BookCategory where+ decode = parseCursor (parseMaybe "BookCategory" bookCategoryFromText)++instance DecodeCursor LibrarySection where+ decode = decodeChoice+ [ choice (laxElement "fiction") decodeFiction+ , choice (laxElement "non_fiction") decodeNonFiction+ ]+ where+ decodeFiction c = Fiction <$> parseCursor parseText c+ decodeNonFiction c = NonFiction <$> parseCursor parseDouble c++instance DecodeCursor Book where+ decode c = Book+ <$> decodeAttr "id" parseInteger c+ <*> decodeSingle (c %/ laxElement "name")+ <*> decodeSingle (c %/ laxElement "section")+ <*> (decodeSingle (c %/ laxElement "published") <&> toDay)+ <*> (decodeMay (c %/ laxElement "lastBorrowed") <&> fmap toUtcT)+ <*> decodeMany (c %/ laxElement "category")++instance DecodeCursor Library where+ decode c = Library+ <$> decodeMany ( c %/ laxElement "book" )++decodeOk :: Assertion+decodeOk = do+ c <- fromDocument <$> loadXmlForTest "ok"+ let r = decodeSingle c+ r @?= Right expectedLibrary+ where+ expectedLibrary = Library+ [ Book+ 1+ "Learn you a haskell for great good!"+ (NonFiction 5.1)+ (fromGregorian 2011 4 21)+ (Just (UTCTime (fromGregorian 2015 1 5) 59400))+ [Programming,Haskell,FunctionalProgramming]+ , Book+ 2+ "Enterprise Pragmatic Scala"+ (Fiction "K")+ (fromGregorian 2013 5 1)+ Nothing+ [Programming,Scala]+ ]++decodeBad :: Assertion+decodeBad = do+ c <- fromDocument <$> loadXmlForTest "bad"+ let r = (decodeSingle c :: DecodeResult Library)+ r @?= Left (+ "'For teh lulz!' was not BookCategory"+ ,[ MoveAxis Child+ , LaxElement "book"+ , MoveAxis Child+ , LaxElement "category"+ ])++decodeBadChoice :: Assertion+decodeBadChoice = do+ c <- fromDocument <$> loadXmlForTest "bad_choice"+ let r = (decodeSingle c :: DecodeResult Library)+ r @?= Left (+ "Choices Exhausted"+ , [ MoveAxis Child , LaxElement "book"+ , MoveAxis Child , LaxElement "section"+ , Choice+ [ [ MoveAxis Child , LaxElement "fiction" ]+ , [ MoveAxis Child , LaxElement "non_fiction" ]]+ Nothing+ ])++decodeFailedDecodeInsideChoice :: Assertion+decodeFailedDecodeInsideChoice = do+ c <- fromDocument <$> loadXmlForTest "bad_decode_inside_choice"+ let r = (decodeSingle c :: DecodeResult Library)+ r @?= Left (+ "'This is not a dewey decimal' was not a double"+ , [ MoveAxis Child , LaxElement "book"+ , MoveAxis Child , LaxElement "section"+ , Choice+ [ [ MoveAxis Child , LaxElement "fiction" ] ]+ (Just [ MoveAxis Child , LaxElement "non_fiction" ])+ ])++loadXmlForTest :: Text -> IO Document+loadXmlForTest tn = readFile def . unpack $ "tests/xml/" <> tn <> ".xml"++tests :: TestTree+tests = testGroup "DecodeTests"+ [ testCase "ok" decodeOk+ , testCase "bad" decodeBad+ , testCase "bad_choice" decodeBadChoice+ , testCase "bad_decode_inside_choice" decodeFailedDecodeInsideChoice+ ]++main :: IO ()+main = defaultMain tests
+ xml-conduit-decode.cabal view
@@ -0,0 +1,49 @@+name: xml-conduit-decode+version: 1.0.0.0+synopsis: Historical cursors & decoding on top of xml-conduit.+description: Created in the sprit of scalaz-xml.+homepage: https://github.com/benkolera/xml-conduit-decode+license: MIT+license-file: LICENSE+author: Ben Kolera+maintainer: ben.kolera@gmail.com+category: XML+build-type: Simple+cabal-version: >=1.10++source-repository head+ type: git+ location: git://git@github.com/benkolera/xml-conduit-decode.git++library+ exposed-modules: Text.XML.Decode+ , Text.XML.Decode.HCursor+ , Text.XML.Decode.Time+ , Text.XML.Decode.DecodeCursor+ , Text.XML.Decode.Parsers+ build-depends: base >= 4.4 && < 5+ , bifunctors >= 5.2 && < 6+ , lens >= 4.1 && < 5+ , semigroups >= 0.18 && < 1+ , text >= 0.11 && < 1.3+ , time >= 1.5 && < 2+ , xml-conduit >= 1.3 && < 2++ hs-source-dirs: src+ default-language: Haskell2010++test-suite test+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: tests+ main-is: Main.hs+ build-depends: base >= 4.4 && < 5+ , data-default+ , lens+ , text+ , tasty+ , tasty-hunit+ , time+ , xml-conduit+ , xml-conduit-decode+ , xml-types