ideas-1.2: src/Ideas/Text/XML/Document.hs
-----------------------------------------------------------------------------
-- Copyright 2014, Open Universiteit Nederland. This file is distributed
-- under the terms of the GNU General Public License. For more information,
-- see the file "LICENSE.txt", which is included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
-- Stability : provisional
-- Portability : portable (depends on ghc)
--
-- Datatype for representing XML documents
--
-----------------------------------------------------------------------------
-- $Id: Document.hs 6535 2014-05-14 11:05:06Z bastiaan $
module Ideas.Text.XML.Document
( Name, Attributes, Attribute(..), Reference(..), Parameter(..)
, XMLDoc(..), XML(..), Element(..), Content, DTD(..), DocTypeDecl(..)
, ContentSpec(..), CP(..), AttType(..), DefaultDecl(..), AttDef
, EntityDef, AttValue, EntityValue, ExternalID(..), PublicID
, Conditional(..), TextDecl, External
, prettyXML, prettyElement
) where
import Text.PrettyPrint.Leijen
type Name = String
type Attributes = [Attribute]
data Attribute = Name := AttValue
data Reference = CharRef Int | EntityRef String
data Parameter = Parameter String
data XMLDoc = XMLDoc
{ versionInfo :: Maybe String
, encoding :: Maybe String
, standalone :: Maybe Bool
, dtd :: Maybe DTD
, externals :: [(String, External)]
, root :: Element
}
data XML = Tagged Element
| CharData String
| CDATA String
| Reference Reference
data Element = Element
{ name :: Name
, attributes :: Attributes
, content :: Content
}
type Content = [XML]
data DTD = DTD Name (Maybe ExternalID) [DocTypeDecl]
data DocTypeDecl = ElementDecl Name ContentSpec
| AttListDecl Name [AttDef]
| EntityDecl Bool Name EntityDef
| NotationDecl Name (Either ExternalID PublicID)
| DTDParameter Parameter
| DTDConditional Conditional
data ContentSpec = Empty | Any | Mixed Bool [Name] | Children CP
-- content particles
data CP = Choice [CP] | Sequence [CP] | QuestionMark CP | Star CP | Plus CP | CPName Name
data AttType = IdType | IdRefType | IdRefsType | EntityType | EntitiesType | NmTokenType | NmTokensType
| StringType | EnumerationType [String] | NotationType [String]
data DefaultDecl = Required | Implied | Value AttValue | Fixed AttValue
type AttDef = (Name, AttType, DefaultDecl)
type EntityDef = Either EntityValue (ExternalID, Maybe String)
type AttValue = [Either Char Reference]
type EntityValue = [Either Char (Either Parameter Reference)]
data ExternalID = System String | Public String String
type PublicID = String
data Conditional = Include [DocTypeDecl] | Ignore [String]
type TextDecl = (Maybe String, String)
type External = (Maybe TextDecl, Content)
------------------------------------------------------------------
-- Showing
instance Show Attribute where show = show . pretty
instance Show Reference where show = show . pretty
instance Show Parameter where show = show . pretty
instance Show XML where show = show . pretty
instance Show Element where show = show . pretty
------------------------------------------------------------------
-- Pretty printing
instance Pretty Attribute where
pretty (n := v) = text n <> char '=' <> prettyAttValue v
instance Pretty Reference where
pretty ref =
case ref of
CharRef n -> text "&#" <> int n <> char ';'
EntityRef s -> char '&' <> text s <> char ';'
instance Pretty Parameter where
pretty (Parameter s) = text "%" <> text s <> text ";"
instance Pretty XML where
pretty = prettyXML False
instance Pretty Element where
pretty = prettyElement False
prettyXML :: Bool -> XML -> Doc
prettyXML compact xml =
case xml of
Tagged e -> prettyElement compact e
CharData s -> text s
CDATA s -> text "<![CDATA[" <> text s <> text "]]>"
Reference r -> pretty r
prettyElement :: Bool -> Element -> Doc
prettyElement compact (Element n as c)
| null c = openCloseTag n as
| compact = make (<>)
| otherwise = make (<$>)
where
make op = let body = foldr1 op (map (prettyXML compact) c)
ibody = (if compact then id else indent 2) body
in openTag n as `op` ibody `op` closeTag n
{-
instance Show XMLDoc where
show doc = showXMLDecl doc ++ maybe "" show (dtd doc) ++ show (root doc)
instance Show DTD where
show (DTD n mid ds) = "<!DOCTYPE " ++ unwords list ++ ">"
where
list = n : catMaybes [fmap show mid, showDecls ds]
showDecls xs
| null xs = Nothing
| otherwise = Just $ "[" ++ concatMap show xs ++ "]"
instance Show ExternalID where
show extID =
case extID of
System s -> "SYSTEM " ++ doubleQuote s
Public p s -> unwords ["PUBLIC", doubleQuote p, doubleQuote s]
instance Show DocTypeDecl where
show decl =
case decl of
ElementDecl n c -> "<!ELEMENT " ++ n ++ " " ++ show c ++ ">"
AttListDecl n as -> "<!ATTLIST " ++ unwords (n:map showAttDef as) ++ ">"
EntityDecl b n e ->
let xs = ["%" | not b] ++ [n, showEntityDef e]
in "<!ENTITY " ++ unwords xs ++ ">"
NotationDecl n e ->
let f s = "PUBLIC " ++ doubleQuote s
in "<!NOTATION " ++ n ++ " " ++ either show f e ++ ">"
DTDParameter r -> show r
DTDConditional c -> show c
instance Show ContentSpec where
show cspec =
case cspec of
Empty -> "EMPTY"
Any -> "ANY"
Mixed b ns ->
let txt = intercalate "|" ("#PCDATA":ns)
in parenthesize txt ++ (if b then "*" else "")
Children cp -> show cp
instance Show CP where
show cp =
case cp of
Choice xs -> parenthesize (intercalate "|" (map show xs))
Sequence xs -> parenthesize (intercalate "," (map show xs))
QuestionMark c -> show c ++ "?"
Star c -> show c ++ "*"
Plus c -> show c ++ "+"
CPName n -> n
instance Show AttType where
show attType =
case attType of
IdType -> "ID"
IdRefType -> "IDREF"
IdRefsType -> "IDREFS"
EntityType -> "ENTITY"
EntitiesType -> "ENTITIES"
NmTokenType -> "NMTOKEN"
NmTokensType -> "NMTOKENS"
StringType -> "CDATA"
EnumerationType xs -> parenthesize (intercalate "|" xs)
NotationType xs -> "NOTATION " ++ parenthesize (intercalate "|" xs)
instance Show DefaultDecl where
show defaultDecl =
case defaultDecl of
Required -> "#REQUIRED"
Implied -> "#IMPLIED"
Value v -> showAttValue v
Fixed v -> "#FIXED " ++ showAttValue v
instance Show Conditional where
show conditional =
case conditional of
Include xs -> "<![INCLUDE[" ++ concatMap show xs ++ "]]>"
Ignore _ -> "" -- ToDO undefined -- [String]
showXMLDecl :: XMLDoc -> String
showXMLDecl doc
| isJust (versionInfo doc) = "<?xml " ++ unwords (catMaybes [s1,s2,s3]) ++ "?>"
| otherwise = ""
where
s1 = fmap (\s -> "version=" ++ doubleQuote s) (versionInfo doc)
s2 = fmap (\s -> "encoding=" ++ doubleQuote s) (encoding doc)
s3 = fmap (\b -> "standalone=" ++ doubleQuote (if b then "yes" else "no")) (standalone doc)
-}
openTag :: Name -> Attributes -> Doc
openTag = prettyTag (char '<') (char '>')
openCloseTag :: Name -> Attributes -> Doc
openCloseTag = prettyTag (char '<') (text "/>")
closeTag :: Name -> Doc
closeTag n = prettyTag (text "</") (char '>') n []
prettyTag :: Doc -> Doc -> Name -> Attributes -> Doc
prettyTag open close n as = open <> hsep (text n:map pretty as) <> close
prettyAttValue :: AttValue -> Doc -- TODO: no double quotes allowed (should be escaped)
prettyAttValue = dquotes . hcat . map (either f pretty)
where
f '"' = empty
f c = char c
{-
showEntityValue :: EntityValue -> String
showEntityValue = doubleQuote . concatMap (either f (either show show))
where
f '"' = []
f c = [c]
showAttDef :: AttDef -> String
showAttDef (s, tp, dd) = unwords [s, show tp, show dd]
showEntityDef :: EntityDef -> String
showEntityDef entityDef =
case entityDef of
Left ev -> showEntityValue ev
Right (eid, ms) -> show eid ++ maybe "" (" NDATA "++) ms
parenthesize :: String -> String
parenthesize s = "(" ++ s ++ ")" -}