module Data.DTD.Render
(
buildDTD
, buildDTDTextDecl
, buildDTDComponent
, buildEntityDecl
, buildElementDecl
, buildContentDecl
, buildContentModel
, buildRepeat
, buildAttList
, buildAttDecl
, buildAttType
, buildAttDefault
, buildNotation
, buildNotationSource
, buildInstruction
, buildComment
, buildExternalID
, buildList
, buildChoice
, buildMaybe
, newline
, space
, quote
, pbracket
, parens
)
where
import Blaze.ByteString.Builder (Builder)
import Blaze.ByteString.Builder.Char.Utf8 (fromText, fromChar)
import Data.DTD.Types
import Data.XML.Types (ExternalID(..), Instruction(..))
import Data.Text (Text)
import Data.Monoid (Monoid(..))
import Data.List (intersperse)
import System.IO (nativeNewline, Newline(CRLF))
(<>) :: Monoid m => m -> m -> m
(<>) = mappend
buildMaybe :: (a -> Builder) -> Maybe a -> Builder
buildMaybe = maybe mempty
newline :: Builder
newline = fromText $ case nativeNewline of
CRLF -> "\r\n"
_ -> "\n"
space :: Builder
space = fromChar ' '
quote :: Builder -> Builder
quote = (fromChar '"' <>) . (<> fromChar '"')
pbracket :: Builder -> Builder
pbracket = (fromText "<!" <>) . (<> fromChar '>')
parens :: Builder -> Builder
parens = (fromChar '(' <>) . (<> fromChar ')')
buildList :: Text -> (a -> Builder) -> [a] -> Builder
buildList sep build =
parens . mconcat . intersperse (fromText sep) . map build
buildChoice :: (a -> Builder) -> [a] -> Builder
buildChoice = buildList " | "
buildDTD :: DTD -> Builder
buildDTD (DTD decl cmps) = buildMaybe buildDTDTextDecl decl <>
mconcat (map ((<> newline) . buildDTDComponent) cmps)
buildDTDTextDecl :: DTDTextDecl -> Builder
buildDTDTextDecl (DTDTextDecl ver enc) = fromText "<?xml " <>
buildMaybe
((fromText "version=" <>) . (<> space) . quote . fromText) ver <>
fromText "encoding=" <> quote (fromText enc) <> fromText "?>" <> newline
buildDTDComponent :: DTDComponent -> Builder
buildDTDComponent (DTDEntityDecl d) = buildEntityDecl d
buildDTDComponent (DTDElementDecl d) = buildElementDecl d
buildDTDComponent (DTDAttList a) = buildAttList a
buildDTDComponent (DTDNotation n) = buildNotation n
buildDTDComponent (DTDInstruction i) = buildInstruction i
buildDTDComponent (DTDComment c) = buildComment c
buildEntityDecl :: EntityDecl -> Builder
buildEntityDecl d = pbracket $ fromText "ENTITY " <> pct <> name <> val
where
name = fromText (entityDeclName d) <> space
(pct, val) = case d of
InternalGeneralEntityDecl _ val' -> (mempty, quote $ fromText val')
ExternalGeneralEntityDecl _ eid nt -> (mempty, ege eid nt)
ege eid nt = buildExternalID eid <>
buildMaybe ((fromText " NDATA " <>) . quote . fromText) nt
buildExternalID :: ExternalID -> Builder
buildExternalID (SystemID sys) = fromText "SYSTEM " <>
quote (fromText sys)
buildExternalID (PublicID pub sys) = fromText "PUBLIC " <>
quote (fromText pub) <> space <>
quote (fromText sys)
buildElementDecl :: ElementDecl -> Builder
buildElementDecl (ElementDecl name content) = pbracket $
fromText "ELEMENT " <> fromText name <> space <> buildContentDecl content
buildContentDecl :: ContentDecl -> Builder
buildContentDecl ContentEmpty = fromText "EMPTY"
buildContentDecl ContentAny = fromText "ANY"
buildContentDecl (ContentElement cm) = buildContentModel cm
buildContentDecl (ContentMixed names) =
buildChoice fromText ("#PCDATA" : names) <> fromChar '*'
buildContentModel :: ContentModel -> Builder
buildContentModel (CMName nam rpt) = parens $ fromText nam <> buildRepeat rpt
buildContentModel cm = buildCM cm
where
buildCM (CMName name rpt) = fromText name <> buildRepeat rpt
buildCM (CMChoice cms rpt) = cp buildChoice cms rpt
buildCM (CMSeq cms rpt) = cp (buildList ", ") cms rpt
cp f cms rpt = f buildCM cms <> buildRepeat rpt
buildRepeat :: Repeat -> Builder
buildRepeat One = mempty
buildRepeat ZeroOrOne = fromChar '?'
buildRepeat ZeroOrMore = fromChar '*'
buildRepeat OneOrMore = fromChar '+'
buildAttList :: AttList -> Builder
buildAttList (AttList name decls) = pbracket $
fromText "ATTLIST " <> fromText name <> mconcat
(map ((newline <>) . (fromText " " <>) . buildAttDecl) decls)
buildAttDecl :: AttDecl -> Builder
buildAttDecl (AttDecl name typ dflt) = fromText name <> space <>
buildAttType typ <> space <> buildAttDefault dflt
buildAttType :: AttType -> Builder
buildAttType AttStringType = fromText "CDATA"
buildAttType AttIDType = fromText "ID"
buildAttType AttIDRefType = fromText "IDREF"
buildAttType AttIDRefsType = fromText "IDREFS"
buildAttType AttEntityType = fromText "ENTITY"
buildAttType AttEntitiesType = fromText "ENTITIES"
buildAttType AttNmTokenType = fromText "NMTOKEN"
buildAttType AttNmTokensType = fromText "NMTOKENS"
buildAttType (AttEnumType vs) = buildChoice fromText vs
buildAttType (AttNotationType ns) = fromText "NOTATION " <>
buildChoice fromText ns
buildAttDefault :: AttDefault -> Builder
buildAttDefault AttRequired = fromText "#REQUIRED"
buildAttDefault AttImplied = fromText "#IMPLIED"
buildAttDefault (AttDefaultValue val) = quote (fromText val)
buildAttDefault (AttFixed val) = fromText "#FIXED " <>
quote (fromText val)
buildNotation :: Notation -> Builder
buildNotation (Notation name src) = pbracket $
fromText "NOTATION " <> fromText name <> space <> buildNotationSource src
buildNotationSource :: NotationSource -> Builder
buildNotationSource (NotationSysID sys) = fromText "SYSTEM " <>
quote (fromText sys)
buildNotationSource (NotationPubID pub) = fromText "PUBLIC " <>
quote (fromText pub)
buildNotationSource (NotationPubSysID pub sys) = fromText "PUBLIC " <>
quote (fromText pub) <>
space <>
quote (fromText sys)
buildInstruction :: Instruction -> Builder
buildInstruction (Instruction trgt dat) =
fromText "<?" <> fromText trgt <> space <> fromText dat <> fromText "?>"
buildComment :: Text -> Builder
buildComment cmt = pbracket $ fromText "--" <> fromText cmt <> fromText "--"