module Data.XML.Types
(
Document (..)
, Prologue (..)
, Instruction (..)
, Miscellaneous (..)
, Node (..)
, Element (..)
, Content (..)
, Name (..)
, Doctype (..)
, ExternalID (..)
, Event (..)
, isElement
, isInstruction
, isContent
, isComment
, isNamed
, elementChildren
, elementContent
, elementText
, nodeChildren
, nodeContent
, nodeText
, hasAttribute
, hasAttributeText
, attributeContent
, attributeText
) where
import Control.Monad ((>=>))
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)
data Document = Document
{ documentPrologue :: Prologue
, documentRoot :: Element
, documentEpilogue :: [Miscellaneous]
}
deriving (Show, Eq, Ord, Typeable)
data Prologue = Prologue
{ prologueBefore :: [Miscellaneous]
, prologueDoctype :: Maybe Doctype
, prologueAfter :: [Miscellaneous]
}
deriving (Show, Eq, Ord, Typeable)
data Instruction = Instruction
{ instructionTarget :: Text
, instructionData :: Text
}
deriving (Show, Eq, Ord, Typeable)
data Miscellaneous
= MiscInstruction Instruction
| MiscComment Text
deriving (Show, Eq, Ord, Typeable)
data Node
= NodeElement Element
| NodeInstruction Instruction
| NodeContent Content
| NodeComment Text
deriving (Show, Eq, Ord, Typeable)
data Element = Element
{ elementName :: Name
, elementAttributes :: [(Name, [Content])]
, elementNodes :: [Node]
}
deriving (Show, Eq, Ord, Typeable)
data Content
= ContentText Text
| ContentEntity Text
deriving (Show, Eq, Ord, Typeable)
data Name = Name
{ nameLocalName :: Text
, nameNamespace :: Maybe Text
, namePrefix :: Maybe Text
}
deriving (Show, Typeable)
instance Eq Name where
(==) = (==) `on` (\x -> (nameNamespace x, nameLocalName x))
instance Ord Name where
compare = compare `on` (\x -> (nameNamespace x, nameLocalName x))
instance IsString Name where
fromString "" = Name T.empty Nothing Nothing
fromString full@('{':rest) = case break (== '}') rest of
(_, "") -> error ("Invalid Clark notation: " ++ show full)
(ns, local) -> Name (T.pack (drop 1 local)) (Just (T.pack ns)) Nothing
fromString local = Name (T.pack local) Nothing Nothing
data Doctype = Doctype
{ doctypeName :: Text
, doctypeID :: Maybe ExternalID
}
deriving (Show, Eq, Ord, Typeable)
data ExternalID
= SystemID Text
| PublicID Text Text
deriving (Show, Eq, Ord, Typeable)
data Event
= EventBeginDocument
| EventEndDocument
| EventBeginDoctype Text (Maybe ExternalID)
| EventEndDoctype
| EventInstruction Instruction
| EventBeginElement Name [(Name, [Content])]
| EventEndElement Name
| EventContent Content
| EventComment Text
| EventCDATA Text
deriving (Show, Eq, Ord, Typeable)
isElement :: Node -> [Element]
isElement (NodeElement e) = [e]
isElement _ = []
isInstruction :: Node -> [Instruction]
isInstruction (NodeInstruction i) = [i]
isInstruction _ = []
isContent :: Node -> [Content]
isContent (NodeContent c) = [c]
isContent _ = []
isComment :: Node -> [Text]
isComment (NodeComment t) = [t]
isComment _ = []
isNamed :: Name -> Element -> [Element]
isNamed n e = [e | elementName e == n]
elementChildren :: Element -> [Element]
elementChildren = elementNodes >=> isElement
elementContent :: Element -> [Content]
elementContent = elementNodes >=> isContent
elementText :: Element -> [Text]
elementText = elementContent >=> contentText
nodeChildren :: Node -> [Node]
nodeChildren = isElement >=> elementNodes
nodeContent :: Node -> [Content]
nodeContent = nodeChildren >=> isContent
nodeText :: Node -> [Text]
nodeText = nodeContent >=> contentText
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 = 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)