diff --git a/Data/XML/Types.hs b/Data/XML/Types.hs --- a/Data/XML/Types.hs +++ b/Data/XML/Types.hs @@ -1,28 +1,26 @@ --- Copyright (c) 2010 John Millikin +-- | +-- Module: Data.XML.Types +-- Copyright: 2010-2011 John Millikin +-- License: MIT -- --- 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: +-- Maintainer: jmillikin@gmail.com +-- Portability: portable -- --- The above copyright notice and this permission notice shall be --- included in all copies or substantial portions of the Software. +-- Basic types for representing XML. -- --- 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. - +-- The idea is to have a full set of appropriate types, which various XML +-- libraries can share. Instead of having equivalent-but-incompatible types +-- for every binding, parser, or client, they all share the same types can +-- can thus interoperate easily. +-- +-- This library contains complete types for most parts of an XML document, +-- including the prologue, node tree, and doctype. Some basic combinators +-- are included for common tasks, including traversing the node tree and +-- filtering children. +-- module Data.XML.Types ( -- * Types + -- ** Document prologue Document (..) , Prologue (..) @@ -32,38 +30,52 @@ -- ** Document body , Node (..) , Element (..) - , Attribute (..) , Content (..) , Name (..) - , Named (..) -- ** Doctypes , Doctype (..) , ExternalID (..) - , InternalSubset + , DoctypeNode (..) + , Declaration -- ** Incremental processing , Event (..) - -- * Predicates + -- * Combinators + + -- ** Filters , isElement , isInstruction , isContent , isComment , isNamed - -- * Filters - , nodeChildren + -- ** Element traversal , elementChildren , elementContent + , elementText + + -- ** Node traversal + , nodeChildren + , nodeContent + , nodeText + + -- ** Attributes , hasAttribute - , position + , hasAttributeText + , attributeContent + , attributeText ) where import Control.Monad ((>=>)) -import Data.Text.Lazy (Text) -import qualified Data.Text.Lazy as T +import qualified Data.Map as M +import Data.Maybe (isJust) +import Data.Text (Text) +import qualified Data.Text as T import Data.String (IsString, fromString) import Data.Function (on) +import Data.Typeable ( Typeable, TypeRep, typeOf + , mkTyConApp, mkTyCon) data Document = Document { documentPrologue :: Prologue @@ -72,6 +84,9 @@ } deriving (Show, Eq) +instance Typeable Document where + typeOf = typeString "Document" + data Prologue = Prologue { prologueBefore :: [Miscellaneous] , prologueDoctype :: Maybe Doctype @@ -79,17 +94,26 @@ } deriving (Show, Eq) +instance Typeable Prologue where + typeOf = typeString "Prologue" + data Instruction = Instruction { instructionTarget :: Text , instructionData :: Text } deriving (Show, Eq, Ord) +instance Typeable Instruction where + typeOf = typeString "Instruction" + data Miscellaneous = MiscInstruction Instruction | MiscComment Text deriving (Show, Eq) +instance Typeable Miscellaneous where + typeOf = typeString "Miscellaneous" + data Node = NodeElement Element | NodeInstruction Instruction @@ -97,24 +121,42 @@ | NodeComment Text deriving (Show, Eq) +instance Typeable Node where + typeOf = typeString "Node" + data Element = Element { elementName :: Name - , elementAttributes :: [Attribute] + , elementAttributes :: M.Map Name [Content] , elementNodes :: [Node] } deriving (Show, Eq) -data Attribute = Attribute - { attributeName :: Name - , attributeContent :: [Content] - } - deriving (Show, Eq) +instance Typeable Element where + typeOf = typeString "Element" data Content = ContentText Text - | ContentEntity Text + | ContentEntity Text -- ^ For pass-through parsing deriving (Show, Eq) +instance Typeable Content where + typeOf = typeString "Content" + +-- | A fully qualified name. +-- +-- Prefixes are not semantically important; they are included only to +-- simplify pass-through parsing. When comparing names with 'Eq' or 'Ord' +-- methods, prefixes are ignored. +-- +-- The @IsString@ instance supports Clark notation; see +-- and +-- . Use +-- the @OverloadedStrings@ language extension for very simple @Name@ +-- construction: +-- +-- > myname :: Name +-- > myname = "{http://example.com/ns/my-namespace}my-name" +-- data Name = Name { nameLocalName :: Text , nameNamespace :: Maybe Text @@ -122,20 +164,15 @@ } deriving (Show) --- | Ignores prefixes +instance Typeable Name where + typeOf = typeString "Name" + instance Eq Name where (==) = (==) `on` (\x -> (nameNamespace x, nameLocalName x)) --- | Ignores prefixes --- --- Since 0.1.3 instance Ord Name where compare = compare `on` (\x -> (nameNamespace x, nameLocalName x)) --- | Supports Clark notation; see and --- --- --- Since 0.1.2 instance IsString Name where fromString "" = Name T.empty Nothing Nothing fromString full@('{':rest) = case break (== '}') rest of @@ -143,51 +180,78 @@ (ns, local) -> Name (T.pack (drop 1 local)) (Just (T.pack ns)) Nothing fromString local = Name (T.pack local) Nothing Nothing -class Named a where - getName :: a -> Name - -instance Named Element where - getName = elementName - -instance Named Attribute where - getName = attributeName - data Doctype = Doctype { doctypeName :: Text , doctypeExternalID :: Maybe ExternalID - , doctypeInternalSubsets :: [InternalSubset] + , doctypeNodes :: [DoctypeNode] } deriving (Show, Eq) --- | Since 0.1.3 instance Ord Doctype where compare = compare `on` (\x -> (doctypeName x, doctypeExternalID x)) +instance Typeable Doctype where + typeOf = typeString "Doctype" + data ExternalID = SystemID Text | PublicID Text Text deriving (Show, Eq, Ord) -data InternalSubset = InternalSubset - -- TODO +instance Typeable ExternalID where + typeOf = typeString "ExternalID" + +data DoctypeNode + = DoctypeDeclaration Declaration + | DoctypeInstruction Instruction + | DoctypeComment Text deriving (Show, Eq) +instance Typeable DoctypeNode where + typeOf = typeString "DoctypeNode" + +-- | Internal doctype declarations are still largely unimplemented. This +-- type will be populated and published in a later version of @xml-types@. +-- +data Declaration + = DeclareElement Text + | DeclareAttributeList Text + | DeclareEntity Text + | DeclareNotation Text + deriving (Show, Eq) + +instance Typeable Declaration where + typeOf = typeString "Declaration" + -- | Some XML processing tools are incremental, and work in terms of events --- rather than node trees. Defining the event type here, even though it won't --- be useful to most users, allows these packages to interoperate more easily. +-- rather than node trees. The 'Event' type allows a document to be fully +-- specified as a sequence of events. -- --- Since: 0.1.1 +-- Event-based XML libraries include: +-- +-- * +-- +-- * +-- +-- * +-- data Event = EventBeginDocument | EventEndDocument + | EventBeginDoctype Text (Maybe ExternalID) + | EventDeclaration Declaration + | EventEndDoctype | EventInstruction Instruction - | EventDoctype Doctype - | EventBeginElement Name [Attribute] + | EventBeginElement Name (M.Map Name [Content]) | EventEndElement Name | EventContent Content | EventComment Text + | EventCDATA Text deriving (Show, Eq) +instance Typeable Event where + typeOf = typeString "Event" + isElement :: Node -> [Element] isElement (NodeElement e) = [e] isElement _ = [] @@ -204,26 +268,45 @@ isComment (NodeComment t) = [t] isComment _ = [] -isNamed :: Named a => Name -> a -> [a] -isNamed n x = [x | getName x == n] +isNamed :: Name -> Element -> [Element] +isNamed n e = [e | elementName e == n] elementChildren :: Element -> [Element] elementChildren = elementNodes >=> isElement --- | Since 0.1.4 elementContent :: Element -> [Content] elementContent = elementNodes >=> isContent +elementText :: Element -> [Text] +elementText = elementContent >=> contentText + nodeChildren :: Node -> [Node] nodeChildren = isElement >=> elementNodes -position :: Integer -> (a -> [b]) -> a -> [b] -position n f e = safeHead n (f e) +nodeContent :: Node -> [Content] +nodeContent = nodeChildren >=> isContent -safeHead :: Integer -> [a] -> [a] -safeHead _ [] = [] -safeHead 0 (x:_) = [x] -safeHead n (_:xs) = safeHead (n - 1) xs +nodeText :: Node -> [Text] +nodeText = nodeContent >=> contentText -hasAttribute :: (Attribute -> [Attribute]) -> Element -> [Element] -hasAttribute f e = [e | not $ null (elementAttributes e >>= f)] +hasAttribute :: Name -> Element -> [Element] +hasAttribute name e = [e | isJust (attributeContent name e)] + +hasAttributeText :: Name -> (Text -> Bool) -> Element -> [Element] +hasAttributeText name p e = [e | maybe False p (attributeText name e)] + +attributeContent :: Name -> Element -> Maybe [Content] +attributeContent name e = M.lookup name (elementAttributes e) + +attributeText :: Name -> Element -> Maybe Text +attributeText name e = fmap contentFlat (attributeContent name e) + +contentText :: Content -> [Text] +contentText (ContentText t) = [t] +contentText (ContentEntity entity) = [T.pack "&", entity, T.pack ";"] + +contentFlat :: [Content] -> Text +contentFlat cs = T.concat (cs >>= contentText) + +typeString :: String -> a -> TypeRep +typeString str _ = mkTyConApp (mkTyCon ("Data.XML.Types." ++ str)) [] diff --git a/xml-types.cabal b/xml-types.cabal --- a/xml-types.cabal +++ b/xml-types.cabal @@ -1,5 +1,5 @@ name: xml-types -version: 0.1.4 +version: 0.2 synopsis: Basic types for representing XML license: MIT license-file: license.txt @@ -21,6 +21,7 @@ build-depends: base >=3 && < 5 , text + , containers exposed-modules: Data.XML.Types