diff --git a/examples/courses.hs b/examples/courses.hs --- a/examples/courses.hs +++ b/examples/courses.hs @@ -1,71 +1,83 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PartialTypeSignatures #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS -Wno-unused-top-binds #-} -import Control.Applicative +import Control.Applicative (optional) import qualified Control.Category as C import Control.Lens hiding (children) import qualified Data.ByteString.Lazy.Char8 as LB import Network.Wreq +import Test.Hspec import Text.XML.Hexml import Text.XML.Hexml.Lens url,url2 :: String url = "http://aiweb.cs.washington.edu/research/projects/xmltk/xmldata/data/courses/reed.xml" url2 = "http://aiweb.cs.washington.edu/research/projects/xmltk/xmldata/data/courses/uwm.xml" -url_local = "/Users/pepe/Downloads/reed.xml" -url2_local = "/Users/pepe/Downloads/uwm.xml" type Strings = String data Place s = Place - { building :: s - , room :: Int + { _building :: s + , _room :: Int } deriving Show data Course s = Course - { title :: s - , instructor :: Maybe s - , place :: Maybe (Place s) - , sections :: [Section s] + { _title :: s + , _courseInstructor :: Maybe s + , _place :: Maybe (Place s) + , _courseSections :: [Section s] } deriving Show data Section s = Section - { name :: s - , days :: s - , start, end :: s - , instructor :: s + { _name :: s + , _days :: s + , _start, _end :: s + , _instructor :: s } deriving Show +makeFields ''Place +makeFields ''Course +makeFields ''Section + main :: IO () main = do - r <- get url2_local - let courses = take 10 $ r ^.. responseBody . to stripDocTypeB . _XML . node "course_listing" . courseF - print courses + r <- get url + r2 <- get url2 + let parser :: Fold (Response LB.ByteString) (Course Strings) + parser = responseBody . to stripDocTypeB . _XML . _children . folded . courseF + lengthOf parser r `shouldBe` 2510 + lengthOf parser r2 `shouldBe` 2112 + r `shouldSatisfy` allOf (parser.sections) null + r2 `shouldSatisfy` allOf (parser.sections) (not.null) stripDocTypeB :: LB.ByteString -> LB.ByteString stripDocTypeB = LB.unlines . drop 2 . LB.lines -stripDocType :: String -> String -stripDocType = unlines . drop 2 . lines courseF :: Fold Node (Course Strings) courseF = runFold $ do - title <- field "title" - instructor <- optional $ field "instructor" - place <- optional $ Fold $ node "place" . placeF - sections <- Fold $ many $ node "section_listing" . sectionF + _title <- field "title" + _courseInstructor <- optional $ field "instructor" + _place <- optional $ Fold $ node "place" . placeF + _courseSections <- Fold $ multiple $ node "section_listing" . sectionF return Course{..} sectionF :: Fold Node (Section Strings) sectionF = runFold $ do - instructor <- field "instructor" - name <- field "section" - days <- field "days" - (start, end) <- Fold $ node "hours" . runFold hoursF + _instructor <- field "instructor" + _name <- field "section" + _days <- field "days" + (_start, _end) <- Fold $ node "hours" . runFold hoursF return Section{..} hoursF :: ReifiedFold Node (Strings, Strings) diff --git a/hexml-lens.cabal b/hexml-lens.cabal --- a/hexml-lens.cabal +++ b/hexml-lens.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: hexml-lens -version: 0.2.0 +version: 0.2.1 synopsis: Lenses for the hexml package description: Lenses for the hexml package category: lens @@ -19,40 +19,36 @@ extra-source-files: README.md -flag buildExamples - description: build the examples - manual: True - default: False - library hs-source-dirs: src build-depends: base >= 4.7 && < 5 , bytestring + , contravariant , foundation , hexml , lens + , profunctors , text exposed-modules: Main Text.XML.Hexml.Lens default-language: Haskell2010 -executable courses +test-suite courses + type: exitcode-stdio-1.0 main-is: courses.hs hs-source-dirs: examples - if flag(buildExamples) - build-depends: - base - , bytestring - , hexml - , hexml-lens - , lens - , wreq - else - buildable: False + build-depends: + base + , bytestring + , hexml + , hexml-lens + , hspec + , lens + , wreq default-language: Haskell2010 test-suite doctests diff --git a/src/Text/XML/Hexml/Lens.hs b/src/Text/XML/Hexml/Lens.hs --- a/src/Text/XML/Hexml/Lens.hs +++ b/src/Text/XML/Hexml/Lens.hs @@ -8,23 +8,26 @@ _children , XML(..) , node + , multiple ) where import Control.Arrow -import Control.Lens hiding (children) -import qualified Data.ByteString as Strict -import qualified Data.ByteString.Internal as Strict -import qualified Data.ByteString.Lazy as Lazy +import Control.Lens hiding (children) +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Internal as Strict +import qualified Data.ByteString.Lazy as Lazy import Data.ByteString.Lens +import Data.Functor.Contravariant +import Data.Profunctor.Unsafe import Data.String -import qualified Data.Text as Strict -import qualified Data.Text.Encoding as Strict -import qualified Data.Text.Lazy as Lazy -import qualified Data.Text.Lazy.Encoding as Lazy +import qualified Data.Text as Strict +import qualified Data.Text.Encoding as Strict +import qualified Data.Text.Lazy as Lazy +import qualified Data.Text.Lazy.Encoding as Lazy import Data.Text.Lens -import qualified Foundation as F -import qualified Foundation.Array.Internal as F -import qualified Foundation.String as F +import qualified Foundation as F +import qualified Foundation.Array.Internal as F +import qualified Foundation.String as F import Text.XML.Hexml -- | Getter for the element children @@ -63,7 +66,6 @@ -- >>> parse "" ^? _Right.re(_XML @String)._XML.to name -- Just "foo" _XML :: Prism' s Node - -- | Fold over all the children (text and element) _contents :: Fold Node (Either s Node) -- | Getter for the 'inner' contents of a node @@ -166,6 +168,9 @@ -- | A more restricted version of 'firsting' which works on 'Fold's lefting :: Fold l l' -> Fold (Either l a) (Either l' a) lefting fold = runFold (left $ Fold fold) + +multiple :: Getting [a] s a -> IndexPreservingGetter s [a] +multiple l = dimap (getConst #. l (Const #. (:[]))) phantom -- Test setup -- ---------------------------------------------------------------------------------