diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Text/XML/Decode.hs b/src/Text/XML/Decode.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/Decode.hs @@ -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: + +@ + + + Learn you a haskell for great good! +
+ 5.1 +
+ 2011-04-21 + 2015-01-05T16:30:00Z + Programming + Haskell + Functional Programming + + +@ + +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 diff --git a/src/Text/XML/Decode/DecodeCursor.hs b/src/Text/XML/Decode/DecodeCursor.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/Decode/DecodeCursor.hs @@ -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 diff --git a/src/Text/XML/Decode/HCursor.hs b/src/Text/XML/Decode/HCursor.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/Decode/HCursor.hs @@ -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 diff --git a/src/Text/XML/Decode/Parsers.hs b/src/Text/XML/Decode/Parsers.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/Decode/Parsers.hs @@ -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 diff --git a/src/Text/XML/Decode/Time.hs b/src/Text/XML/Decode/Time.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/Decode/Time.hs @@ -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" diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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 diff --git a/xml-conduit-decode.cabal b/xml-conduit-decode.cabal new file mode 100644 --- /dev/null +++ b/xml-conduit-decode.cabal @@ -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