diff --git a/Data/XML/DTD/Parse.hs b/Data/XML/DTD/Parse.hs --- a/Data/XML/DTD/Parse.hs +++ b/Data/XML/DTD/Parse.hs @@ -8,7 +8,8 @@ -- Portability : portable -- -- This module provides a "Data.Attoparsec.Text" parser for XML --- Document Type Declaration (DTD) documents. +-- Document Type Declaration (DTD) documents. A higher-level interface +-- that implements parameter entity resolution is also provided. {- Copyright (c) 2011 Suite Solutions Ltd., Israel. All rights reserved. @@ -20,7 +21,8 @@ module Data.XML.DTD.Parse ( -- * Parsing a DTD - parseDTD + dtd + , parseDTD , parseDTDWithExtern , SymTable @@ -78,12 +80,15 @@ import Data.Maybe (fromMaybe, catMaybes) import Data.List (groupBy) --- | Parse a DTD. If the syntax of the DTD is invalid, all --- declarations up to the first invalid one are returned. +-- | Parse a DTD while fully resolving the values of all parameter +-- entities whose values are provided internally in the DTD. If the +-- syntax of the DTD is invalid, all declarations up to the first +-- invalid one are returned. parseDTD :: L.Text -> DTD parseDTD = parseDTDWithExtern M.empty --- | Parse a DTD using the given table of values for external +-- | Parse a DTD while fully resolving the values of parameter +-- entities. The given table of values is used to resolve external -- parameter entities. -- -- If you need information from the DTD itself to look up the external @@ -131,6 +136,7 @@ handlePre (Done c (PInstruction i)) = DTDInstruction i : parseCmps ext int c handlePre (Done c (PMarkup m)) = handleMarkup ext int c m + handlePre _ = [] -- | Pre-parse a single DTD component at the beginning of the current -- input text. Pre-parsing separates components that need parameter @@ -248,6 +254,14 @@ pERefText :: PERef -> Text pERefText r = T.concat ["%", r, ";"] +-- | Parse a DTD. Parameter entity substitution is not supported by +-- this parser, so parameter entities cannot appear in places where a +-- valid DTD syntax production cannot be determined without resolving +-- them. +dtd :: Parser DTD +dtd = DTD <$> (skipWS *> optional (textDecl <* skipWS)) <*> + many (dtdComponent <* skipWS) + -- | Parse an @?xml@ text declaration at the beginning of a 'DTD'. textDecl :: Parser DTDTextDecl textDecl = do @@ -273,7 +287,7 @@ [ DTDPERef <$> pERef , DTDEntityDecl <$> entityDecl , DTDElementDecl <$> elementDecl - , DTDAttList <$> attList + , DTDAttList <$> attList , DTDNotation <$> notation , DTDInstruction <$> instruction ] ++ -- no try needed for last choice @@ -391,15 +405,18 @@ -- | Parse the type of an attribute. attType :: Parser AttType attType = choice $ map try - [ "CDATA" .*> pure AttStringType - , "ID" .*> pure AttIDType - , "IDREF" .*> pure AttIDRefType - , "IDREFS" .*> pure AttIDRefsType - , "ENTITY" .*> pure AttEntityType - , "ENTITIES" .*> pure AttEntitiesType - , "NMTOKEN" .*> pure AttNmTokenType - , "NMTOKENS" .*> pure AttNmTokensType - , AttEnumType <$> try enumType + -- The ws is required by the spec, and needed by the parser to be + -- able to distinguish between ID and IDREF, and NMTOKEN and + -- NMTOKENS. + [ "CDATA" .*> ws *> pure AttStringType + , "ID" .*> ws *> pure AttIDType + , "IDREF" .*> ws *> pure AttIDRefType + , "IDREFS" .*> ws *> pure AttIDRefsType + , "ENTITY" .*> ws *> pure AttEntityType + , "ENTITIES" .*> ws *> pure AttEntitiesType + , "NMTOKEN" .*> ws *> pure AttNmTokenType + , "NMTOKENS" .*> ws *> pure AttNmTokensType + , AttEnumType <$> enumType ] ++ [ AttNotationType <$> notationType ] diff --git a/Data/XML/DTD/Render.hs b/Data/XML/DTD/Render.hs new file mode 100644 --- /dev/null +++ b/Data/XML/DTD/Render.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE OverloadedStrings #-} +------------------------------------------------------------------------------ +-- | +-- Module : Data.XML.DTD.Render +-- Copyright : Suite Solutions Ltd., Israel 2011 +-- +-- Maintainer : Yitzchak Gale +-- Portability : portable +-- +-- A "Blaze.ByteString.Builder" renderer for XML Document Type +-- Declaration (DTD) documents. + +{- +Copyright (c) 2011 Suite Solutions Ltd., Israel. All rights reserved. + +For licensing information, see the BSD3-style license in the file +license.txt that was originally distributed by the author together +with this file. +-} + +module Data.XML.DTD.Render + ( -- * DTD structure + buildDTD + , buildDTDTextDecl + , buildDTDComponent + + -- * Entity declarations and references + , buildEntityDecl + , buildEntityValue + , buildPERef + + -- * Element declarations + , buildElementDecl + , buildContentDecl + , buildContentModel + , buildRepeat + + -- * Attribute declarations + , buildAttList + , buildAttDecl + , buildAttType + , buildAttDefault + + -- * Notation declarations + , buildNotation + , buildNotationSource + + -- * Comments and processing instructions + , buildInstruction + , buildComment + + -- * Builder combinators for general DTD syntax + , 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.XML.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)) +-- No instance Semigroup Builder yet, so <> defined here manually. +--import Data.Semigroup ((<>)) +(<>) = mappend + +-- | Build an optional item. +buildMaybe :: (a -> Builder) -> Maybe a -> Builder +buildMaybe = maybe mempty + +-- | Build a newline. +newline :: Builder +newline = fromText $ case nativeNewline of + CRLF -> "\r\n" + _ -> "\n" + +-- | Build a space. +space :: Builder +space = fromChar ' ' + +-- | Build a quoted string. +quote :: Builder -> Builder +quote = (fromChar '"' <>) . (<> fromChar '"') + +-- | Build a string quoted by angle brackets, with an exclamation mark. +pbracket :: Builder -> Builder +pbracket = (fromText ") . (<> fromChar '>') + +-- | Build a string surround by parantheses. +parens :: Builder -> Builder +parens = (fromChar '(' <>) . (<> fromChar ')') + +-- | Build a list of items +buildList :: Text -> (a -> Builder) -> [a] -> Builder +buildList sep build = + parens . mconcat . intersperse (fromText sep) . map build + +-- | Build a choice expression. +buildChoice :: (a -> Builder) -> [a] -> Builder +buildChoice = buildList " | " + +-- | A 'Builder' for a 'DTD'. +buildDTD (DTD decl cmps) = buildMaybe buildDTDTextDecl decl <> + mconcat (map ((<> newline) . buildDTDComponent) cmps) + +-- | A 'Builder' for a 'DTDTextDecl'. +buildDTDTextDecl :: DTDTextDecl -> Builder +buildDTDTextDecl (DTDTextDecl ver enc) = fromText " + buildMaybe + ((fromText "version=" <>) . (<> space) . quote . fromText) ver <> + fromText "encoding=" <> quote (fromText enc) <> fromText "?>" <> newline + +-- | A 'Builder' for a 'DTDComponent'. +buildDTDComponent :: DTDComponent -> Builder +buildDTDComponent (DTDEntityDecl d) = buildEntityDecl d +buildDTDComponent (DTDElementDecl d) = buildElementDecl d +buildDTDComponent (DTDAttList a) = buildAttList a +buildDTDComponent (DTDNotation n) = buildNotation n +buildDTDComponent (DTDPERef r) = buildPERef r +buildDTDComponent (DTDInstruction i) = buildInstruction i +buildDTDComponent (DTDComment c) = buildComment c + +-- | A 'Builder' for an 'EntityDecl'. +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, buildEntityValue val) + ExternalGeneralEntityDecl _ eid nt -> (mempty, ege eid nt) + InternalParameterEntityDecl _ val -> (pctBld, buildEntityValue val) + ExternalParameterEntityDecl _ eid -> (pctBld, buildExternalID eid) + pctBld = fromText "% " + ege eid nt = buildExternalID eid <> + buildMaybe ((fromText " NDATA " <>) . quote . fromText) nt + +-- | A 'Builder' for an 'ExternalID'. +buildExternalID :: ExternalID -> Builder +buildExternalID (SystemID sys) = fromText "SYSTEM " <> + quote (fromText sys) +buildExternalID (PublicID pub sys) = fromText "PUBLIC " <> + quote (fromText pub) <> space <> + quote (fromText sys) + +-- | A 'Builder' for an entity value, consisting of a list of +-- 'EntityValue'. +buildEntityValue :: [EntityValue] -> Builder +buildEntityValue = quote . mconcat . map val + where + val (EntityText t) = fromText t + val (EntityPERef r) = buildPERef r + +-- | A builder for a 'PERef'. +buildPERef :: PERef -> Builder +buildPERef r = fromChar '%' <> fromText r <> fromChar ';' + +-- | A 'Builder' for an 'ElementDecl'. +buildElementDecl :: ElementDecl -> Builder +buildElementDecl (ElementDecl name content) = pbracket $ + fromText "ELEMENT " <> fromText name <> space <> buildContentDecl content + +-- | A 'Builder' for a 'ContentDecl'. +buildContentDecl :: ContentDecl -> Builder +buildContentDecl ContentEmpty = fromText "EMPTY" +buildContentDecl ContentAny = fromText "ANY" +buildContentDecl (ContentElement cm) = buildContentModel cm +buildContentDecl (ContentMixed names) = + buildChoice fromText ("#PCDATA" : names) <> fromChar '*' + +-- | A 'Builder' for a 'ContentModel'. +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 + +-- | A 'Builder' for a 'Repeat'. +buildRepeat :: Repeat -> Builder +buildRepeat One = mempty +buildRepeat ZeroOrOne = fromChar '?' +buildRepeat ZeroOrMore = fromChar '*' +buildRepeat OneOrMore = fromChar '+' + +-- | A 'Builder' for an 'AttList'. +buildAttList :: AttList -> Builder +buildAttList (AttList name decls) = pbracket $ + fromText "ATTLIST " <> fromText name <> mconcat + (map ((newline <>) . (fromText " " <>) . buildAttDecl) decls) + +-- | A 'Builder' for an 'AttDecl'. +buildAttDecl :: AttDecl -> Builder +buildAttDecl (AttDecl name typ dflt) = fromText name <> space <> + buildAttType typ <> space <> buildAttDefault dflt + +-- | A 'Builder' for an 'AttType'. +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 + +-- | A 'Builder' for an 'AttDefault'. +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) + +-- | A 'Builder' for a 'Notation'. +buildNotation :: Notation -> Builder +buildNotation (Notation name src) = pbracket $ + fromText "NOTATION " <> fromText name <> space <> buildNotationSource src + +-- | A 'Builder' for a 'NotationSource'. +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) + +-- | A 'Builder' for an 'Instruction'. +buildInstruction :: Instruction -> Builder +buildInstruction (Instruction trgt dat) = + fromText " fromText trgt <> space <> fromText dat <> fromText "?>" + +-- | A 'Builder' for a comment. The comment text cannot be null, +-- cannot contain two consecutive '-', and cannot end in '-'. +buildComment :: Text -> Builder +buildComment cmt = pbracket $ fromText "--" <> fromText cmt <> fromText "--" diff --git a/dtd-text.cabal b/dtd-text.cabal --- a/dtd-text.cabal +++ b/dtd-text.cabal @@ -1,8 +1,8 @@ name: dtd-text -version: 0.1.0.0 +version: 0.1.1.0 synopsis: Parse and render XML DTDs description: - This library provides an attoparse-text parser and blaze-builder for + This library provides an attoparsec-text parser and blaze-builder for XML Document Type Declaration (DTD) documents. license: BSD3 license-file: license.txt @@ -29,8 +29,8 @@ , xml-types ==0.3.* , attoparsec ==0.8.* , attoparsec-text ==0.8.* --- , blaze-builder ==0.3.* + , blaze-builder ==0.3.* exposed-modules: Data.XML.DTD.Parse --- Data.XML.DTD.Render + Data.XML.DTD.Render