{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__
{-# LANGUAGE DeriveDataTypeable #-}
#if MIN_VERSION_base(4,4,0)
{-# LANGUAGE DeriveGeneric #-}
#endif
#endif
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.Function (on)
import Data.Maybe (isJust)
import Data.String (IsString, fromString)
import Data.Text (Text)
import qualified Data.Text as T
import Control.DeepSeq (NFData(rnf))
#if __GLASGOW_HASKELL__
import Data.Typeable (Typeable)
import Data.Data (Data)
#if MIN_VERSION_base(4,4,0)
import GHC.Generics (Generic)
#endif
#endif
data Document = Document
{ documentPrologue :: Prologue
, documentRoot :: Element
, documentEpilogue :: [Miscellaneous]
}
deriving (Eq, Ord, Show
#if __GLASGOW_HASKELL__
, Data, Typeable
#if MIN_VERSION_base(4,4,0)
, Generic
#endif
#endif
)
instance NFData Document where
rnf (Document a b c) = rnf a `seq` rnf b `seq` rnf c `seq` ()
data Prologue = Prologue
{ prologueBefore :: [Miscellaneous]
, prologueDoctype :: Maybe Doctype
, prologueAfter :: [Miscellaneous]
}
deriving (Eq, Ord, Show
#if __GLASGOW_HASKELL__
, Data, Typeable
#if MIN_VERSION_base(4,4,0)
, Generic
#endif
#endif
)
instance NFData Prologue where
rnf (Prologue a b c) = rnf a `seq` rnf b `seq` rnf c `seq` ()
data Instruction = Instruction
{ instructionTarget :: Text
, instructionData :: Text
}
deriving (Eq, Ord, Show
#if __GLASGOW_HASKELL__
, Data, Typeable
#if MIN_VERSION_base(4,4,0)
, Generic
#endif
#endif
)
instance NFData Instruction where
rnf (Instruction a b) = rnf a `seq` rnf b `seq` ()
data Miscellaneous
= MiscInstruction Instruction
| MiscComment Text
deriving (Eq, Ord, Show
#if __GLASGOW_HASKELL__
, Data, Typeable
#if MIN_VERSION_base(4,4,0)
, Generic
#endif
#endif
)
instance NFData Miscellaneous where
rnf (MiscInstruction a) = rnf a `seq` ()
rnf (MiscComment a) = rnf a `seq` ()
data Node
= NodeElement Element
| NodeInstruction Instruction
| NodeContent Content
| NodeComment Text
deriving (Eq, Ord, Show
#if __GLASGOW_HASKELL__
, Data, Typeable
#if MIN_VERSION_base(4,4,0)
, Generic
#endif
#endif
)
instance NFData Node where
rnf (NodeElement a) = rnf a `seq` ()
rnf (NodeInstruction a) = rnf a `seq` ()
rnf (NodeContent a) = rnf a `seq` ()
rnf (NodeComment a) = rnf a `seq` ()
instance IsString Node where
fromString = NodeContent . fromString
data Element = Element
{ elementName :: Name
, elementAttributes :: [(Name, [Content])]
, elementNodes :: [Node]
}
deriving (Eq, Ord, Show
#if __GLASGOW_HASKELL__
, Data, Typeable
#if MIN_VERSION_base(4,4,0)
, Generic
#endif
#endif
)
instance NFData Element where
rnf (Element a b c) = rnf a `seq` rnf b `seq` rnf c `seq` ()
data Content
= ContentText Text
| ContentEntity Text
deriving (Eq, Ord, Show
#if __GLASGOW_HASKELL__
, Data, Typeable
#if MIN_VERSION_base(4,4,0)
, Generic
#endif
#endif
)
instance NFData Content where
rnf (ContentText a) = rnf a `seq` ()
rnf (ContentEntity a) = rnf a `seq` ()
instance IsString Content where
fromString = ContentText . fromString
data Name = Name
{ nameLocalName :: Text
, nameNamespace :: Maybe Text
, namePrefix :: Maybe Text
}
deriving (Show
#if __GLASGOW_HASKELL__
, Data, Typeable
#if MIN_VERSION_base(4,4,0)
, Generic
#endif
#endif
)
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
instance NFData Name where
rnf (Name a b c) = rnf a `seq` rnf b `seq` rnf c `seq` ()
data Doctype = Doctype
{ doctypeName :: Text
, doctypeID :: Maybe ExternalID
}
deriving (Eq, Ord, Show
#if __GLASGOW_HASKELL__
, Data, Typeable
#if MIN_VERSION_base(4,4,0)
, Generic
#endif
#endif
)
instance NFData Doctype where
rnf (Doctype a b) = rnf a `seq` rnf b `seq` ()
data ExternalID
= SystemID Text
| PublicID Text Text
deriving (Eq, Ord, Show
#if __GLASGOW_HASKELL__
, Data, Typeable
#if MIN_VERSION_base(4,4,0)
, Generic
#endif
#endif
)
instance NFData ExternalID where
rnf (SystemID a) = rnf a `seq` ()
rnf (PublicID a b) = rnf a `seq` rnf b `seq` ()
data Event
= EventBeginDocument
| EventEndDocument
| EventBeginDoctype Text (Maybe ExternalID)
| EventEndDoctype
| EventInstruction Instruction
| EventBeginElement Name [(Name, [Content])]
| EventEndElement Name
| EventContent Content
| EventComment Text
| EventCDATA Text
deriving (Eq, Ord, Show
#if __GLASGOW_HASKELL__
, Data, Typeable
#if MIN_VERSION_base(4,4,0)
, Generic
#endif
#endif
)
instance NFData Event where
rnf (EventBeginDoctype a b) = rnf a `seq` rnf b `seq` ()
rnf (EventInstruction a) = rnf a `seq` ()
rnf (EventBeginElement a b) = rnf a `seq` rnf b `seq` ()
rnf (EventEndElement a) = rnf a `seq` ()
rnf (EventContent a) = rnf a `seq` ()
rnf (EventComment a) = rnf a `seq` ()
rnf (EventCDATA a) = rnf a `seq` ()
rnf _ = ()
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)