diff --git a/examples/courses.hs b/examples/courses.hs --- a/examples/courses.hs +++ b/examples/courses.hs @@ -1,42 +1,81 @@ -{-# LANGUAGE RecordWildCards #-} -import Control.Lens hiding (children) -import qualified Data.ByteString as B +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS -Wno-unused-top-binds #-} + +import Control.Applicative +import qualified Control.Category as C +import Control.Lens hiding (children) import qualified Data.ByteString.Lazy.Char8 as LB -import Network.Wreq -import Text.XML.Hexml -import Text.XML.Hexml.Lens +import Network.Wreq +import Text.XML.Hexml +import Text.XML.Hexml.Lens -url :: [Char] +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 + , room :: Int } deriving Show data Course s = Course - { title, instructor :: s - , place :: Place s + { title :: s + , instructor :: Maybe s + , place :: Maybe (Place s) + , sections :: [Section s] } deriving Show +data Section s = Section + { name :: s + , days :: s + , start, end :: s + , instructor :: s + } + deriving Show + main :: IO () main = do - r <- get url - let stripDocType = LB.unlines . drop 2 . LB.lines - let courses = take 10 $ r ^.. responseBody . to stripDocType . _XML . _children . courseF + r <- get url2_local + let courses = take 10 $ r ^.. responseBody . to stripDocTypeB . _XML . node "course_listing" . courseF print courses -courseF :: Fold Node (Course B.ByteString) +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 <- Fold $ node "title" . textContents - instructor <- Fold $ node "instructor" . textContents - place <- Fold $ node "place" . placeF - return $ Course{..} + title <- field "title" + instructor <- optional $ field "instructor" + place <- optional $ Fold $ node "place" . placeF + sections <- Fold $ many $ node "section_listing" . sectionF + return Course{..} -placeF :: Fold Node (Place B.ByteString) +sectionF :: Fold Node (Section Strings) +sectionF = runFold $ do + instructor <- field "instructor" + name <- field "section" + days <- field "days" + (start, end) <- Fold $ node "hours" . runFold hoursF + return Section{..} + +hoursF :: ReifiedFold Node (Strings, Strings) +hoursF = (,) <$> field "start" <*> field "end" + +placeF :: Fold Node (Place Strings) placeF = runFold $ do - building <- Fold $ node "building" . textContents - room <- Fold $ node "room" . textContents . _Show + building <- field "building" + room <- Fold _Show C.. field "room" return (Place building room) + +field :: (XML a, XML t) => t -> ReifiedFold Node a +field n = Fold $ node n . _inner 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.1.1 +version: 0.2.0 synopsis: Lenses for the hexml package description: Lenses for the hexml package category: lens @@ -19,6 +19,11 @@ extra-source-files: README.md +flag buildExamples + description: build the examples + manual: True + default: False + library hs-source-dirs: src @@ -38,13 +43,16 @@ main-is: courses.hs hs-source-dirs: examples - build-depends: - base - , bytestring - , hexml - , hexml-lens - , lens - , wreq + if flag(buildExamples) + build-depends: + base + , bytestring + , hexml + , hexml-lens + , lens + , wreq + else + buildable: False default-language: Haskell2010 test-suite doctests @@ -53,7 +61,8 @@ hs-source-dirs: test build-depends: - doctest + base + , doctest , hexml-lens , QuickCheck default-language: Haskell2010 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 @@ -1,167 +1,37 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE RankNTypes #-} module Text.XML.Hexml.Lens ( -- * Nodes _children - , ChildNode(..) - , Contents(..) - , TextContents(..) - -- * Attributes - , Attributes(..) - -- * Parsing - , AsXML(..) + , XML(..) + , node ) 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 Data.ByteString.Lens -import Data.String -import qualified Data.Text as Strict -import qualified Data.Text.Lazy as Lazy -import qualified Data.Text.Encoding as Strict -import qualified Data.Text.Lazy.Encoding as Lazy -import Data.Text.Lens -import qualified Foundation as F -import qualified Foundation.String as F +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 Data.ByteString.Lens +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 Data.Text.Lens +import qualified Foundation as F import qualified Foundation.Array.Internal as F -import Text.XML.Hexml - --- | Fold over the element children -_children :: Fold Node Node -_children = folding children - - -- | Fold over all the children (text and element) -class Contents s where - _contents :: Fold Node (Either s Node) - -instance Contents String where - _contents = _contents . firsting (from strictUtf8) - -instance Contents F.String where - _contents = _contents . lefting (foundation F.UTF8) - -instance Contents Strict.Text where - _contents = _contents . firsting (from strictTextUtf8) - -instance Contents Lazy.Text where - _contents = _contents . firsting (from lazyTextUtf8) - -instance Contents Strict.ByteString where - _contents = folding contents - -instance Contents Lazy.ByteString where - _contents = _contents . firsting lazy - --- --------------------------------------------------------------------------------- --- | Folds for element nodes -class ChildNode s where - -- | Fold over a specific child - node :: s -> Fold Node Node - --- | A fold for accessing named children nodes --- This is a more efficient version of --- --- > node foo = _children . filtered (\n -> name n == foo) -instance ChildNode String where - node name_ = node ( name_ ^. strictUtf8) - --- | A fold for accessing named children nodes --- This is a more efficient version of --- --- > node foo = _children . filtered (\n -> name n == foo) -instance ChildNode F.String where - node name_ = node ( F.toList name_ ^. strictUtf8) - --- | A fold for accessing named children nodes --- This is a more efficient version of --- --- > node foo = _children . filtered (\n -> name n == foo) -instance ChildNode Strict.ByteString where - node name_ = folding $ flip childrenBy name_ - -instance ChildNode Lazy.ByteString where - node name_ = node (name_ ^. strict) - --- | A fold for accessing named children nodes --- This is a more efficient version of --- --- > node foo = _children . filtered (\n -> name n == foo) -instance ChildNode Strict.Text where - node name_ = node ( name_ ^. strictTextUtf8 ) - -instance ChildNode Lazy.Text where - node name_ = node ( name_ ^. lazyTextUtf8 ) - --- | A fold for accessing a child node by its index -instance ChildNode Int where - node n = folding $ take 1 . drop n . children - --- --------------------------------------------------------------------------------- - --- | Fold for accessing the text contents of a node -class TextContents s where - textContents :: Fold Node s - -instance TextContents Strict.ByteString where - textContents = folding contents . _Left - -instance TextContents Lazy.ByteString where - textContents = textContents . lazy - -instance TextContents String where - textContents = textContents @Strict.ByteString . from strictUtf8 - -instance TextContents Strict.Text where - textContents = textContents . from strictTextUtf8 - -instance TextContents Lazy.Text where - textContents = textContents . from lazyTextUtf8 - -instance TextContents F.String where - textContents = textContents . foundation F.UTF8 - --- --------------------------------------------------------------------------------- - --- | Optics for accessing attributes -class Attributes s where - -- | Fold for accessing attributes by name. - _Attribute :: s -> Getter Node (Maybe s) - -- | Name-Indexed fold over the attribute values - iattributes :: IndexedFold String Node s - -instance Attributes Strict.ByteString where - _Attribute n = pre $ to(`attributeBy` n).folded.to(attributeValue) - iattributes = ifolding (map (\ (Attribute n v) -> (n^.from strictUtf8, v)) . attributes ) - -instance Attributes Lazy.ByteString where - _Attribute n = _Attribute(n^.strict).mapping(lazy) - iattributes = iattributes.lazy - -instance Attributes String where - _Attribute n = _Attribute(n ^. packedChars).mapping(from strictUtf8) - iattributes = iattributes @ Strict.ByteString . unpackedChars - -instance Attributes Strict.Text where - _Attribute n = _Attribute(n ^. strictTextUtf8).mapping(from strictTextUtf8) - iattributes = iattributes . packed - -instance Attributes Lazy.Text where - _Attribute n = _Attribute(n ^. lazyTextUtf8).mapping(from lazyTextUtf8) - iattributes = iattributes . packed - -instance Attributes F.String where - _Attribute n = pre $ to (`attributeBy` (F.toList n ^. packedChars)) . folded . to attributeValue . foundation F.UTF8 - iattributes = iattributes . to fromString +import qualified Foundation.String as F +import Text.XML.Hexml --- --------------------------------------------------------------------------------- +-- | Getter for the element children +_children :: Getter Node [Node] +_children = to children -class AsXML s where +class XML s where -- | A prism for parsing and unparsing XML. -- -- unparsing is provided by 'outer'. @@ -174,10 +44,10 @@ -- >>> "" ^? _XML.to name -- Just "" -- - -- >>> "" ^? _XML.node(0::Int) + -- >>> "" ^? _XML._children.ix(0) -- Just Node "" -- - -- >>> "" ^? _XML.node(1::Int) + -- >>> "" ^? _XML._children.ix(1) -- Just Node "" -- -- If the tree has only 1 root, no nameless nodes are inserted. @@ -192,30 +62,93 @@ -- Just "" -- >>> parse "" ^? _Right.re(_XML @String)._XML.to name -- Just "foo" - _XML :: Prism' s Node -instance AsXML Strict.ByteString where - _XML = prism' outer doParse where - doParse x = - case parse x of - Right n -> Just $ case children n of [y] -> y ; _ -> n - Left _ -> Nothing + -- | Fold over all the children (text and element) + _contents :: Fold Node (Either s Node) + -- | Getter for the 'inner' contents of a node + _inner :: Getter Node s + -- | Getter for the 'inner' contents of a node + _outer :: Getter Node s + -- | Fold for accessing the text contents of a node + textContents :: Fold Node s + -- | Fold for accessing attributes by name. + _Attribute :: s -> Getter Node (Maybe s) + -- | Name-Indexed fold over the attribute values + iattributes :: IndexedFold String Node s + -- | A getter for accessing named children nodes + -- This is a more efficient version of + -- + -- > nodes foo = _children . to (filter (\n -> name n == foo)) + nodes :: s -> Getter Node [Node] -instance AsXML Lazy.ByteString where - _XML = strict . _XML @ Strict.ByteString +-- | > node n = nodes n . folded +node :: XML s => s -> Fold Node Node +node n = nodes n . folded -instance AsXML String where +instance XML String where _XML = strictUtf8 . _XML @ Strict.ByteString + _contents = _contents . firsting (from strictUtf8) + _inner = _inner . from strictUtf8 + _outer = _outer . from strictUtf8 + textContents = textContents @Strict.ByteString . from strictUtf8 + _Attribute n = _Attribute(n ^. packedChars).mapping(from strictUtf8) + iattributes = iattributes @ Strict.ByteString . unpackedChars + nodes name_ = nodes ( name_ ^. strictUtf8) -instance AsXML Strict.Text where +instance XML F.String where + _contents = _contents . lefting (foundation F.UTF8) + _inner = _inner . foundation F.UTF8 + _outer = _outer . foundation F.UTF8 + textContents = textContents . foundation F.UTF8 + _Attribute n = pre $ to (`attributeBy` (F.toList n ^. packedChars)) . folded . to attributeValue . foundation F.UTF8 + iattributes = iattributes . to fromString + nodes name_ = nodes ( F.toList name_ ^. strictUtf8) + +instance XML Strict.Text where _XML = strictTextUtf8 . _XML + _contents = _contents . firsting (from strictTextUtf8) + _inner = _inner . from strictTextUtf8 + _outer = _outer . from strictTextUtf8 + textContents = textContents . from strictTextUtf8 + _Attribute n = _Attribute(n ^. strictTextUtf8).mapping(from strictTextUtf8) + iattributes = iattributes . packed + nodes name_ = nodes ( name_ ^. strictTextUtf8 ) -instance AsXML Lazy.Text where +instance XML Lazy.Text where _XML = lazyTextUtf8 . _XML + _contents = _contents . firsting lazy + _inner = _inner . lazy + _outer = _outer . lazy + textContents = textContents . from lazyTextUtf8 + _Attribute n = _Attribute(n ^. lazyTextUtf8).mapping(from lazyTextUtf8) + iattributes = iattributes . packed + nodes name_ = nodes ( name_ ^. lazyTextUtf8 ) --- --------------------------------------------------------------------------------- +instance XML Strict.ByteString where + _XML = prism' outer doParse where + doParse x = + case parse x of + Right n -> Just $ case children n of [y] -> y ; _ -> n + Left _ -> Nothing + _contents = folding contents + _inner = to inner + _outer = to outer + textContents = folding contents . _Left + _Attribute n = pre $ to(`attributeBy` n).folded.to(attributeValue) + iattributes = ifolding (map (\ (Attribute n v) -> (n^.from strictUtf8, v)) . attributes ) + nodes name_ = to $ flip childrenBy name_ +instance XML Lazy.ByteString where + _XML = strict . _XML @ Strict.ByteString + _contents = _contents . firsting lazy + _inner = _inner . lazy + _outer = _outer . lazy + textContents = textContents . lazy + _Attribute n = _Attribute(n^.strict).mapping(lazy) + iattributes = iattributes.lazy + nodes name_ = nodes (name_ ^. strict) + lazyTextUtf8 :: Iso' Lazy.Text Lazy.ByteString lazyTextUtf8 = iso Lazy.encodeUtf8 Lazy.decodeUtf8 @@ -225,8 +158,8 @@ strictUtf8 :: Iso' String Strict.ByteString strictUtf8 = packed . strictTextUtf8 -foundation :: F.Encoding -> Fold Strict.ByteString F.String -foundation encoding = to (F.fromBytes encoding . fromByteString) . filtered (hasn't (_2.folded)) . _1 +foundation :: F.Encoding -> Getter Strict.ByteString F.String +foundation encoding = to (F.fromBytes encoding . fromByteString) . {-. filtered (hasn't (_2.folded))-} _1 where fromByteString = F.fromForeignPtr . Strict.toForeignPtr