dtd (empty) → 0.4.0

raw patch · 9 files changed

+1568/−0 lines, 9 filesdep +attoparsecdep +attoparsec-conduitdep +basesetup-changed

Dependencies added: attoparsec, attoparsec-conduit, base, blaze-builder, conduit, containers, lifted-base, monad-control, network, resourcet, text, transformers, uri-conduit, xml-catalog, xml-conduit, xml-types

Files

Data/DTD/Cache.hs +207/−0
Data/DTD/Parse.hs +295/−0
Data/DTD/Parse/Unresolved.hs +357/−0
Data/DTD/Render.hs +239/−0
Data/DTD/Types.hs +107/−0
Data/DTD/Types/Unresolved.hs +289/−0
LICENSE +30/−0
Setup.lhs +7/−0
dtd.cabal +37/−0

+ Data/DTD/Cache.hs view

@@ -0,0 +1,207 @@+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Data.DTD.Cache
+    ( DTDCache
+    , applyDTD
+    , applyDTD_
+    , newDTDCache
+    , newDTDCacheFile
+    , loadAttrMap
+    , UnresolvedEntity (..)
+    ) where
+
+import qualified Text.XML as X
+import Text.XML.Cursor
+import qualified Data.XML.Types as XU
+import qualified Data.Map as Map
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import Text.XML.Catalog
+import Network.URI.Conduit
+import Network.URI.Conduit.File
+import qualified Data.DTD.Types as D
+import Data.DTD.Parse (readEID, uriToEID)
+import qualified Data.Conduit as C
+import qualified Data.Conduit.List as CL
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import qualified Data.IORef as I
+import Control.Exception (Exception, throwIO, SomeException)
+import Data.Typeable (Typeable)
+import Control.Monad.Trans.Control (MonadBaseControl)
+import qualified Network.URI as NU
+import Control.Exception.Lifted (try)
+import Control.Monad (liftM)
+
+toMaps :: [D.DTDComponent] -> (EntityMap, AttrMap)
+toMaps =
+    foldr go (Map.empty, Map.empty)
+  where
+    go (D.DTDEntityDecl (D.InternalGeneralEntityDecl k v)) (e, a) = (Map.insert k v e, a)
+    go (D.DTDAttList (D.AttList lname atts)) (e, a) =
+        (e, Map.unionWith Map.union (Map.singleton (X.Name lname Nothing Nothing) (Map.unions $ map go' atts)) a)
+    go _ m = m
+
+    go' (D.AttDecl lname _ def) =
+        case def of
+            D.AttFixed t -> Map.singleton name $ Fixed t
+            D.AttDefaultValue t -> Map.singleton name $ Def t
+            _ -> Map.empty
+      where
+        name = X.Name lname Nothing Nothing
+
+data DTDCache = DTDCache
+    { _dcCache :: I.IORef (Map.Map PubSys (EntityMap, AttrMap))
+    , _dcCatalog :: Catalog
+    , _dcSchemeMap :: SchemeMap
+    }
+
+newDTDCache :: MonadIO m' => Catalog -> SchemeMap -> m' DTDCache
+newDTDCache c sm = do
+    x <- liftIO $ I.newIORef Map.empty
+    return $ DTDCache x c sm
+
+newDTDCacheFile :: MonadIO m => FilePath -> m DTDCache
+newDTDCacheFile fp = do
+    uri <- liftIO $ decodeString fp
+    c <- loadCatalog (toSchemeMap [fileScheme]) uri
+    newDTDCache c (toSchemeMap [fileScheme])
+
+loadSchemaAttrMap :: MonadIO m => DTDCache -> Text -> m (EntityMap, AttrMap)
+loadSchemaAttrMap (DTDCache icache catalog sm) uri0 = do
+    res <- liftIO $ fmap (Map.lookup pubsys) $ I.readIORef icache
+    case res of
+        Just dtd -> return dtd
+        Nothing -> liftIO $ do
+            res' <- load uri0
+            let maps = (Map.empty, res')
+            I.atomicModifyIORef icache $ \m ->
+                (Map.insert pubsys maps m, ())
+            return maps
+  where
+    pubsys = Public uri0
+
+    load uri =
+        case resolveURI catalog Nothing (X.PublicID uri uri) of
+            Nothing -> throwIO $ UnknownSchemaURI uri
+            Just uri' -> do
+                doc <- C.runResourceT $ readURI sm uri' C.$$ X.sinkDoc X.def
+                let c = fromDocument doc
+                let includes =
+                        (c $// element "{http://www.w3.org/2001/XMLSchema}include" >=> attribute "schemaLocation") ++
+                        (c $// element "{http://www.w3.org/2001/XMLSchema}redefine" >=> attribute "schemaLocation")
+                ms1 <- mapM load includes
+                let ms2 = c $// element "{http://www.w3.org/2001/XMLSchema}element" >=> go
+                let ms = ms1 ++ map (uncurry Map.singleton) ms2
+                return $ Map.unionsWith Map.union ms
+
+    go c = do
+        name <- attribute "name" c
+        let attrs = c $// element "{http://www.w3.org/2001/XMLSchema}attribute" >=> goA
+        return (X.Name name Nothing Nothing, Map.fromList attrs)
+
+    goA c = do
+        ref <- attribute "ref" c
+        def <- attribute "default" c
+        return (X.Name ref Nothing Nothing, Def def)
+
+loadAttrMap :: MonadIO m => DTDCache -> X.ExternalID -> m (EntityMap, AttrMap)
+loadAttrMap (DTDCache icache catalog sm) ext = do
+    res <- liftIO $ fmap (Map.lookup pubsys) $ I.readIORef icache
+    case res of
+        Just dtd -> return dtd
+        Nothing ->
+            case Map.lookup pubsys catalog of
+                Nothing -> liftIO $ throwIO $ UnknownExternalID ext
+                Just uri -> do
+                    ecomps <- liftIO $ try $ C.runResourceT $ readEID catalog (uriToEID uri) sm C.$$ CL.consume
+                    comps <- either (liftIO . throwIO . CannotLoadDTD (toNetworkURI uri)) return ecomps
+                    let maps = toMaps comps
+                    liftIO $ I.atomicModifyIORef icache $ \m ->
+                        (Map.insert pubsys maps m, ())
+                    return maps
+  where
+    pubsys =
+        case ext of
+            X.SystemID t -> System t
+            X.PublicID t _ -> Public t
+
+data UnknownExternalID = UnknownExternalID X.ExternalID
+                       | CannotLoadDTD NU.URI SomeException
+                       | UnknownSchemaURI Text
+    deriving (Show, Typeable)
+instance Exception UnknownExternalID
+
+data UnresolvedEntity = UnresolvedEntity Text
+    deriving (Show, Typeable)
+instance Exception UnresolvedEntity
+
+applyDTD_ :: (MonadBaseControl IO m, MonadIO m)
+          => DTDCache -> XU.Document -> m X.Document
+applyDTD_ dc doc = applyDTD dc doc >>= either (liftIO . throwIO) return
+
+applyDTD :: (MonadBaseControl IO m, MonadIO m)
+         => DTDCache -> XU.Document -> m (Either UnresolvedEntity X.Document)
+applyDTD dc doc@(XU.Document pro@(X.Prologue _ mdoctype _) root epi) = do
+    mattrs <-
+        case mdoctype of
+            Just (X.Doctype _ (Just extid)) -> liftM Just $ loadAttrMap dc extid
+            _ ->
+                case lookup "{http://www.w3.org/2001/XMLSchema-instance}noNamespaceSchemaLocation" $ XU.elementAttributes root of
+                    Just [XU.ContentText uri] -> liftM Just $ loadSchemaAttrMap dc uri
+                    _ -> return Nothing
+    case mattrs of
+        Nothing -> return $ goD (Map.empty, Map.empty) doc
+        Just attrs ->
+            case go attrs root of
+                Left e -> return $ Left e
+                Right root' -> return $ Right $ X.Document pro root' epi
+  where
+    go :: (EntityMap, AttrMap) -> XU.Element -> Either UnresolvedEntity X.Element
+    go (ents, attrs) (XU.Element name as ns) = do
+        as' <- mapM (resolveAttr ents) as
+        ns' <- mapM gon ns
+        Right $ X.Element name (as'' as') ns'
+      where
+        as'' as' =
+            case Map.lookup name attrs of
+                Nothing -> as'
+                Just x -> foldr goa as' $ Map.toList x
+        gon (XU.NodeElement e) = fmap X.NodeElement $ go (ents, attrs) e
+        gon (XU.NodeComment t) = Right $ X.NodeComment t
+        gon (XU.NodeInstruction t) = Right $ X.NodeInstruction t
+        gon (XU.NodeContent (XU.ContentText t)) = Right $ X.NodeContent t
+        gon (XU.NodeContent (XU.ContentEntity t)) = fmap X.NodeContent $ getEntity ents t
+
+    goa (name, Fixed t) as = (name, t) : filter (\(n, _) -> name /= n) as
+    goa (name, Def t) as =
+        case lookup name as of
+            Nothing -> (name, t) : as
+            Just _ -> as
+
+    goD attrs (XU.Document a r b) =
+        case go attrs r of
+            Left e -> Left e
+            Right root' -> Right $ X.Document a root' b
+
+    resolveAttr ents (k, v) = fmap (\ts -> (k, T.concat ts)) $ mapM (resolveAttr' ents) v
+    resolveAttr' _ (XU.ContentText t) = Right t
+    resolveAttr' ents (XU.ContentEntity t) = getEntity ents t
+
+data Att = Def Text | Fixed Text
+
+type AttrMap = Map.Map X.Name (Map.Map X.Name Att)
+type EntityMap = Map.Map Text Text
+
+getEntity :: EntityMap -> Text -> Either UnresolvedEntity Text
+getEntity ents t = maybe (Left $ UnresolvedEntity t) Right $ do
+    raw <- Map.lookup t ents
+    case X.parseText X.def $ TL.fromChunks ["<dummy>", raw, "</dummy>"] of
+        Right (X.Document _ (X.Element _ _ nodes) _) -> toContent nodes
+        Left{} -> Nothing
+  where
+    toContent = fmap T.concat . mapM toContent'
+    toContent' (X.NodeContent t') = Just t'
+    toContent' _ = Nothing

+ Data/DTD/Parse.hs view

@@ -0,0 +1,295 @@+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Data.DTD.Parse
+    ( readFile_
+    , enumFile
+    , filePathToEID
+    , uriToEID
+    , readEID
+    ) where
+
+import Data.DTD.Types
+import Data.XML.Types (ExternalID (SystemID))
+import qualified Data.DTD.Types.Unresolved as U
+import qualified Data.DTD.Parse.Unresolved as UP
+import Control.Exception (Exception, SomeException, throwIO)
+import qualified Control.Exception.Lifted as Lifted
+import qualified Data.Conduit.List as CL
+import Control.Monad.Trans.Class (MonadTrans, lift)
+import qualified Data.Text as T
+import qualified Data.Map as Map
+import Data.Typeable (Typeable)
+import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)
+import Text.XML.Catalog (resolveURI, Catalog)
+import Network.URI.Conduit (URI, SchemeMap, readURI, toNetworkURI, toSchemeMap)
+import Network.URI.Conduit.File (decodeString, fileScheme)
+import qualified Data.Conduit as C
+import Text.XML.Stream.Parse (detectUtf)
+import Data.Conduit.Attoparsec (sinkParser)
+import Control.Applicative ((*>), (<*), (<|>), (<$>), many)
+import qualified Data.IORef as I
+import Control.Monad.Trans.Control (MonadBaseControl)
+import qualified Data.Attoparsec.Text as A
+import Control.Monad (liftM)
+import Control.Monad.IO.Class (MonadIO (liftIO))
+
+type ResolveMonad m = ReaderT ResolveReader m
+
+readEID :: (C.MonadResource m, MonadBaseControl IO m)
+        => Catalog
+        -> ExternalID
+        -> SchemeMap
+        -> C.Source m DTDComponent
+readEID catalog eid sm =
+    C.SourceM pull (return ())
+  where
+    pull =
+        case resolveURI catalog Nothing eid of
+            Nothing -> liftIO $ throwIO $ CannotResolveExternalID eid
+            Just uri -> do
+                istate <- liftIO $ I.newIORef initState
+                let rr = ResolveReader catalog uri istate sm
+                return $ readerToEnum rr
+
+readerToEnum :: (MonadBaseControl IO m, C.MonadThrow m, MonadIO m, C.MonadResource m)
+             => ResolveReader -> C.Source m DTDComponent
+readerToEnum rr =
+    addCatch src0
+  where
+    src0 =
+        readURI (rrSchemeMap rr) (rrBase rr)
+                C.$= detectUtf
+                C.$= streamUnresolved
+                C.$= CL.concatMap id
+                C.$= resolveEnum rr
+    addCatch = id -- FIXME
+    {-
+    addCatch src = C.Source
+        { C.sourcePull = do
+            res <- C.sourcePull src `Lifted.catch` (lift . throw rr)
+            return $ case res of
+                C.Open src' val -> C.Open (addCatch src') val
+                C.Closed -> C.Closed
+        , C.sourceClose = return ()
+        }
+        -}
+
+throw :: C.MonadThrow m => ResolveReader -> SomeException -> m a
+throw rr e =
+    C.monadThrow $ OccuredAt (show $ toNetworkURI $ rrBase rr) (ResolveOther e)
+
+readFile_ :: FilePath -> IO [DTDComponent]
+readFile_ fp = C.runResourceT $ enumFile fp C.$$ CL.consume
+
+enumFile :: (MonadBaseControl IO m, C.MonadResource m) => FilePath -> C.Source m DTDComponent
+enumFile fp =
+    C.SourceM pull (return ())
+  where
+    pull = do
+        eid <- filePathToEID fp
+        return $ readEID Map.empty eid $ toSchemeMap [fileScheme]
+
+filePathToEID :: MonadIO m => FilePath -> m ExternalID
+filePathToEID = liftM uriToEID . liftIO . decodeString
+
+uriToEID :: URI -> ExternalID
+uriToEID = SystemID . T.pack . show . toNetworkURI
+
+streamUnresolved :: C.MonadThrow m => C.Conduit T.Text m [U.DTDComponent]
+streamUnresolved =
+    C.sequenceSink () $ const $ C.Emit () . return <$> sinkParser p
+  where
+    p = (UP.ws >> UP.skipWS >> return []) <|>
+        (UP.textDecl >> return []) <|>
+        (UP.dtdComponent >>= return . return) <|>
+        (A.endOfInput >> return [])
+
+resolveEnum :: (MonadBaseControl IO m, C.MonadThrow m, MonadIO m, C.MonadUnsafeIO m)
+            => ResolveReader
+            -> C.Conduit U.DTDComponent m DTDComponent
+resolveEnum rr =
+      C.transConduit (evalStateT' rr)
+    $ CL.concatMapM resolvef
+
+evalStateT' :: Monad m
+            => ResolveReader
+            -> ReaderT ResolveReader m a
+            -> m a
+evalStateT' rr m = do
+    a <- runReaderT m rr
+    return a
+
+data ResolveState = ResolveState
+    { rsRefText :: Map.Map U.PERef T.Text
+    , rsRefEid :: Map.Map U.PERef ExternalID
+    }
+    deriving Show
+
+data ResolveReader = ResolveReader
+    { rrCatalog :: Catalog
+    , rrBase :: URI
+    , rrState :: I.IORef ResolveState
+    , rrSchemeMap :: SchemeMap
+    }
+
+get :: MonadIO m => ReaderT ResolveReader m ResolveState
+get = do
+    rr <- ask
+    liftIO $ I.readIORef $ rrState rr
+
+put :: MonadIO m => ResolveState -> ReaderT ResolveReader m ()
+put rs = do
+    rr <- ask
+    liftIO $ I.writeIORef (rrState rr) rs
+
+modify :: MonadIO m => (ResolveState -> ResolveState) -> ReaderT ResolveReader m ()
+modify f = get >>= put . f
+
+initState :: ResolveState
+initState = ResolveState Map.empty Map.empty
+
+resolvef :: (MonadBaseControl IO m, C.MonadThrow m, MonadIO m, C.MonadUnsafeIO m)
+         => U.DTDComponent
+         -> ResolveMonad m [DTDComponent]
+
+-- passthrough, no modification needed
+resolvef (U.DTDNotation x) = return [DTDNotation x]
+resolvef (U.DTDInstruction x) = return [DTDInstruction x]
+resolvef (U.DTDComment x) = return [DTDComment x]
+resolvef (U.DTDEntityDecl (U.ExternalGeneralEntityDecl a b c)) =
+    return [DTDEntityDecl $ ExternalGeneralEntityDecl a b c]
+
+-- look up the EntityValues
+resolvef (U.DTDEntityDecl (U.InternalGeneralEntityDecl a b)) = do
+    rs <- get
+    case resolveEntityValue rs b of
+        Left e -> throwError' e
+        Right t -> return [DTDEntityDecl $ InternalGeneralEntityDecl a t]
+
+-- store external entities
+resolvef (U.DTDEntityDecl (U.ExternalParameterEntityDecl name eid)) = do
+    modify $ \rs -> rs { rsRefEid = insertNoReplace name eid $ rsRefEid rs }
+    return []
+
+-- store internal entities
+resolvef (U.DTDEntityDecl (U.InternalParameterEntityDecl name vals)) = do
+    rs <- get
+    t <- either throwError' return $ resolveEntityValue rs vals
+    put $ rs { rsRefText = insertNoReplace name t $ rsRefText rs }
+    return []
+
+-- pull in perefs
+resolvef (U.DTDPERef p) = do
+    rs <- get
+    case Map.lookup p $ rsRefEid rs of
+        Nothing -> throwError' $ UnknownPERef p
+        Just eid -> do
+            rr <- ask
+            case resolveURI (rrCatalog rr) (Just $ rrBase rr) eid of
+                Nothing -> throwError' $ CannotResolveExternalID eid
+                Just uri -> do
+                    let rr' = rr { rrBase = uri }
+                    C.runResourceT $ readerToEnum rr' C.$$ CL.consume
+
+-- element declarations
+resolvef (U.DTDElementDecl (U.ElementDecl name' c)) = do
+    name <- either resolvePERefText return name'
+    c' <-
+        case c of
+            U.ContentEmpty -> return ContentEmpty
+            U.ContentAny -> return ContentAny
+            U.ContentElement ev -> resolveContentModel ev
+            U.ContentMixed cm -> return $ ContentMixed cm
+            U.ContentPERef p -> do
+                t <- resolvePERefText p
+                case runPartial $ A.parse (UP.skipWS *> UP.contentDecl <* UP.skipWS) t of
+                    A.Done "" x ->
+                        case x of
+                            U.ContentPERef{} -> throwError' $ RecursiveContentDeclPERef p
+                            U.ContentEmpty -> return ContentEmpty
+                            U.ContentAny -> return ContentAny
+                            U.ContentElement cm -> resolveContentModel cm
+                            U.ContentMixed cm -> return $ ContentMixed cm
+                    x -> throwError' $ InvalidContentDecl p t x
+    return [DTDElementDecl $ ElementDecl name c']
+
+-- attribute list
+resolvef (U.DTDAttList (U.AttList name' xs)) = do
+    name <- either resolvePERefText return name'
+    ys <- mapM resolveAttDeclPERef xs
+    return [DTDAttList $ AttList name $ concat ys]
+
+resolveAttDeclPERef :: (MonadIO m, C.MonadThrow m) => U.AttDeclPERef -> ResolveMonad m [AttDecl]
+resolveAttDeclPERef (U.ADPDecl (U.AttDecl name typ def)) = do
+    typ' <-
+        case typ of
+            U.ATPType t -> return t
+            U.ATPPERef p -> do
+                t <- resolvePERefText p
+                case runPartial $ A.parse UP.attType $ T.strip t `T.append` " " of
+                    A.Done "" x -> return x
+                    x -> throwError' $ InvalidAttType p t x
+    return [AttDecl name typ' def]
+resolveAttDeclPERef (U.ADPPERef p) = do
+    t <- resolvePERefText p
+    case runPartial $ A.parse (many UP.attDecl) $ T.strip t of
+        A.Done "" x -> liftM concat $ mapM (resolveAttDeclPERef . U.ADPDecl) x
+        x -> throwError' $ InvalidAttDecl p t x
+
+throwError' :: C.MonadThrow m => ResolveException' -> ResolveMonad m a
+throwError' e = do
+    uri <- liftM rrBase ask
+    lift $ C.monadThrow $ OccuredAt (show $ toNetworkURI uri) e
+
+runPartial :: A.Result t -> A.Result t
+runPartial (A.Partial f) = f ""
+runPartial r = r
+
+resolvePERefText :: (MonadIO m, C.MonadThrow m) => U.PERef -> ResolveMonad m T.Text
+resolvePERefText p = do
+    rs <- get
+    maybe (throwError' $ UnknownPERefText p) return $ Map.lookup p $ rsRefText rs
+
+resolveEntityValue :: ResolveState -> [U.EntityValue] -> Either ResolveException' T.Text
+resolveEntityValue rs evs =
+    fmap T.concat $ mapM go evs
+  where
+    go (U.EntityText t) = Right t
+    go (U.EntityPERef p) =
+        case Map.lookup p $ rsRefText rs of
+            Nothing -> Left $ UnknownPERefValue p
+            Just t -> Right t
+
+resolveContentModel :: (MonadIO m, C.MonadThrow m) => [U.EntityValue] -> ResolveMonad m ContentDecl
+resolveContentModel ev = do
+    rs <- get
+    text <- either throwError' return $ resolveEntityValue rs ev
+    case runPartial $ A.parse UP.contentModel $ T.strip text of
+        A.Done "" x -> return $ ContentElement x
+        x -> throwError' $ InvalidContentModel text x
+
+data ResolveException = OccuredAt String ResolveException'
+  deriving (Show, Typeable)
+instance Exception ResolveException
+
+data ResolveException'
+    = UnknownPERef U.PERef
+    | UnknownPERefValue U.PERef
+    | UnknownPERefText U.PERef
+    | CannotResolveExternalID ExternalID
+    | InvalidContentDecl U.PERef T.Text (A.Result U.ContentDecl)
+    | InvalidContentModel T.Text (A.Result U.ContentModel)
+    | InvalidAttDecl U.PERef T.Text (A.Result [U.AttDecl])
+    | InvalidAttType U.PERef T.Text (A.Result U.AttType)
+    | RecursiveContentDeclPERef U.PERef
+    | ResolveOther SomeException
+  deriving (Show, Typeable)
+instance Exception ResolveException'
+
+insertNoReplace :: Ord k => k -> v -> Map.Map k v -> Map.Map k v
+insertNoReplace k v m =
+    case Map.lookup k m of
+        Nothing -> Map.insert k v m
+        Just{} -> m

+ Data/DTD/Parse/Unresolved.hs view

@@ -0,0 +1,357 @@+{-# LANGUAGE OverloadedStrings #-}
+------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.XML.DTD.Parse
+-- Copyright   :  Suite Solutions Ltd., Israel 2011
+--
+-- Maintainer  :  Yitzchak Gale <gale@sefer.org>
+-- Portability :  portable
+--
+-- This module provides a "Data.Attoparsec.Text" parser for XML
+-- 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.
+
+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.DTD.Parse.Unresolved
+  ( -- * Parsing a DTD
+    dtd
+
+    -- * Top-level DTD structure
+  , textDecl
+  , dtdComponent
+
+    -- * Entity declarations and references
+  , entityDecl
+  , entityValue
+  , pERef
+  , notation
+  , notationSrc
+
+    -- * Element declarations
+  , elementDecl
+  , contentDecl
+  , contentModel
+  , repeatChar
+
+    -- * Attribute declarations
+  , attList
+  , attDecl
+  , attDeclPERef
+  , attType
+  , attDefault
+
+    -- * Declarations of comments and processing instructions
+  , instruction
+  , comment
+
+    -- * Parsing combinators for general DTD syntax
+  , externalID
+  , name
+  , nameSS
+  , quoted
+  , skipWS
+  , ws
+  ) 
+  where
+
+import Data.DTD.Types.Unresolved
+import Data.XML.Types (ExternalID(PublicID, SystemID),
+  Instruction(Instruction))
+import Data.Attoparsec.Text (Parser, try, satisfy, takeTill,
+  anyChar, char, digit)
+import qualified Data.Attoparsec.Text as A -- for takeWhile
+import Data.Attoparsec.Combinator (manyTill, choice, sepBy1)
+import Data.Functor ((<$>))
+import Control.Applicative (pure, optional, (<*>), (<*), (*>), (<|>),
+    Applicative, many)
+import Control.Monad (guard)
+import Data.Text (Text)
+import Data.Char (isSpace)
+import qualified Data.Text as T
+
+(<*.) :: Parser a -> T.Text -> Parser a
+a <*. b = a <* A.string b
+
+(.*>) :: T.Text -> Parser a -> Parser a
+a .*> b = A.string a *> b
+
+-- | A pre-parsed component of the DTD. Pre-parsing separates
+-- components that need parameter entity replacement from those that
+-- do not.
+data PreParse =
+     PPERef PERef
+   | PInstruction Instruction
+   | PComment Text
+   | PMarkup [MarkupText]
+  deriving (Eq, Show)
+
+-- | Markup text is interspersed quoted 'Text', unquoted 'Text', and
+-- parameter entity references.
+data MarkupText = MTUnquoted Text | MTQuoted Text | MTPERef PERef
+  deriving (Eq, Show)
+
+-- | 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
+    "<?" .*> xml *> ws *> skipWS
+    enc1 <- optional $ try encoding
+    ver  <- optional $ try (maybeSpace version enc1)
+    enc  <- maybe (maybeSpace encoding ver) return enc1
+    skipWS *> "?>" .*> pure (DTDTextDecl ver enc)
+  where
+    xml = (A.string "X" <|> A.string "x") *>
+          (A.string "M" <|> A.string "m") *>
+          (A.string "L" <|> A.string "l")
+    version = attr "version" $ const versionNum
+    versionNum = T.append <$> A.string "1." <*> (T.singleton <$> digit)
+    encoding = attr "encoding" $ takeTill . (==)
+    attr name' val = try (attrQ '"' name' val) <|> attrQ '\'' name' val
+    attrQ q name' val = name' .*> skipWS *> "=" .*> skipWS *>
+                       char q *> val q <* char q
+    maybeSpace p = maybe p (const $ ws *> skipWS *> p)
+
+-- | Parse a single component of a 'DTD'. Conditional sections are
+-- currently not supported.
+dtdComponent :: Parser DTDComponent
+dtdComponent = choice $ map try
+  [ DTDPERef       <$> pERef
+  , DTDEntityDecl  <$> entityDecl
+  , DTDElementDecl <$> elementDecl
+  , DTDAttList     <$> attList
+  , DTDNotation    <$> notation
+  , DTDInstruction <$> instruction
+  ] ++ -- no try needed for last choice
+  [ DTDComment     <$> comment
+  ]
+
+-- | Parse a processing instruction.
+instruction :: Parser Instruction
+instruction = Instruction <$> ("<?" .*> skipWS *> nameSS) <*>
+                              idata <*. "?>"
+  where
+    -- Break the content into chunks beginning with '?' so we
+    -- can find the '?>' at the end. The first chunk might not
+    -- begin with '?'.
+    idata = T.concat . concat <$> manyTillS chunk (A.string "?>")
+    chunk = list2 . T.singleton <$> anyChar <*> takeTill (== '?')
+
+-- | Parse an entity declaration.
+entityDecl :: Parser EntityDecl
+entityDecl = "<!ENTITY" .*> ws *> skipWS *>
+                choice [try internalParam, try externalParam,
+                        try internalGen,   externalGen]
+              <* skipWS <*. ">"
+  where
+    internalParam = InternalParameterEntityDecl <$>
+                      (param *> nameSS) <*> entityValue
+    externalParam = ExternalParameterEntityDecl <$>
+                      (param *> nameSS) <*> externalID
+    internalGen = InternalGeneralEntityDecl <$> nameSS <*> entityValue
+    externalGen = ExternalGeneralEntityDecl <$>
+                    nameSS <*> externalID <*> optional (try ndata)
+    param = "%" .*> ws *> skipWS
+    ndata = skipWS *> "NDATA" .*> ws *> skipWS *> name
+
+-- | Parse a DTD name. We are much more liberal than the spec: we
+-- allow any characters that will not interfere with other DTD
+-- syntax. This parser subsumes both @Name@ and @NmToken@ in the spec,
+-- and more.
+name :: Parser Text
+name = nonNull $ takeTill notNameChar
+  where
+    notNameChar c = isSpace c || c `elem` syntaxChars
+    syntaxChars = "()[]<>!%&;'\"?*+|,="
+    nonNull parser = do
+      text <- parser
+      guard . not . T.null $ text
+      return text
+
+-- | Parse a DTD 'name' followed by optional white space.
+nameSS :: Parser Text
+nameSS = name <* skipWS
+
+nameSSP :: Parser (Either PERef Text)
+nameSSP = ((Left <$> pERef) <|> (Right <$> name)) <* skipWS
+
+-- | Parse an entity value. An entity value is a quoted string
+-- possibly containing parameter entity references.
+entityValue :: Parser [EntityValue]
+entityValue = try (quotedVal '"') <|> quotedVal '\''
+  where
+    quotedVal q = char q *> manyTill (content q) (char q)
+    content q =  EntityPERef <$> try pERef <|> EntityText <$> text q
+    text q = takeTill $ \c -> c == '%' || c == q
+
+entityValueUnquoted :: Parser [EntityValue]
+entityValueUnquoted = many $
+    ((EntityPERef <$> pERef) <|>
+    (EntityText <$> (A.takeWhile1 $ not . flip elem "%>")))
+
+-- | Parse a parameter entity reference
+pERef :: Parser PERef
+pERef = "%" .*> name <*. ";"
+
+-- | Parse the declaration of an element.
+elementDecl :: Parser ElementDecl
+elementDecl = ElementDecl <$> ("<!ELEMENT" .*> ws *> skipWS *> nameSSP) <*>
+                              contentDecl <* skipWS <*. ">"
+
+-- | Parse the content that can occur in an element.
+contentDecl :: Parser ContentDecl
+contentDecl = choice $ map try
+    [ pure ContentEmpty <*. "EMPTY"
+    , pure ContentAny   <*. "ANY"
+    ,      ContentMixed <$> pcdata
+    , ContentPERef <$> pERef
+    ] ++
+    [      ContentElement <$> entityValueUnquoted
+    ]
+  where
+    pcdata = "(" .*> skipWS *> "#PCDATA" .*> skipWS *>
+             (try tags <|> noTagsNoStar)
+    tags = many ("|" .*> skipWS *> nameSS) <*. ")*"
+    noTagsNoStar = ")" .*> pure []
+
+-- | Parse the model of structured content for an element.
+contentModel :: Parser ContentModel
+contentModel = choice $ map (<*> repeatChar)
+    [ CMChoice <$> try (cmList '|')
+    , CMSeq    <$> try (cmList ',')
+    , CMName   <$> name
+    ]
+  where
+    cmList sep = "(" .*> skipWS *>
+      ((contentModel <* skipWS) `sepBy1` (char sep *> skipWS)) <*. ")"
+
+-- | Parse a repetition character.
+repeatChar :: Parser Repeat
+repeatChar = choice
+  [ char '?' *> pure ZeroOrOne
+  , char '*' *> pure ZeroOrMore
+  , char '+' *> pure OneOrMore
+  ,             pure One
+  ]
+
+-- | Parse a list of attribute declarations for an element.
+attList :: Parser AttList
+attList = AttList <$> ("<!ATTLIST" .*> ws *> skipWS *> nameSSP) <*>
+                       many attDeclPERef <*. ">"
+
+attDeclPERef :: Parser AttDeclPERef
+attDeclPERef = (ADPPERef <$> pERef <* skipWS) <|> (ADPDecl <$> attDecl)
+
+-- | Parse the three-part declaration of an attribute.
+attDecl :: Parser AttDecl
+attDecl = AttDecl <$>
+           nameSS <*> attTypePERef <* skipWS <*> attDefault <* skipWS
+
+attTypePERef :: Parser AttTypePERef
+attTypePERef = (ATPPERef <$> pERef) <|> (ATPType <$> attType)
+
+-- | Parse the type of an attribute.
+attType :: Parser AttType
+attType = choice $ map try
+    -- 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
+    ]
+  where
+    enumType = nameList
+    notationType = "NOTATION" .*> ws *> skipWS *> nameList
+    nameList = "(" .*> skipWS *>
+               (nameSS `sepBy1` ("|" .*> skipWS)) <*. ")"
+
+-- | Parse a default value specification for an attribute.
+attDefault :: Parser AttDefault
+attDefault = choice $ map try
+    [ "#REQUIRED" .*> pure AttRequired
+    , "#IMPLIED"  .*> pure AttImplied
+    , AttFixed <$> ("#FIXED" .*> ws *> skipWS *> quoted)
+    ] ++
+    [ AttDefaultValue <$> quoted
+    ]
+
+-- | A single-quoted or double-quoted string. The quotation marks are
+-- dropped.
+quoted :: Parser Text
+quoted = quotedWith '"' <|> quotedWith '\''
+  where
+    quotedWith q = char q *> takeTill (== q) <* char q
+
+-- | Parse a declaration of a notation.
+notation :: Parser Notation
+notation = Notation <$>
+  ("<!NOTATION" .*> ws *> skipWS *> name) <* ws <* skipWS <*>
+  notationSrc <*. ">"
+
+-- | Parse a source for a notation.
+notationSrc :: Parser NotationSource
+notationSrc = try system <|> public
+  where
+    system = NotationSysID <$>
+      ("SYSTEM" .*> ws *> skipWS *> quoted <* ws <* skipWS)
+    public = mkPublic <$>
+      ("PUBLIC" .*> ws *> skipWS *> quoted) <*>
+      optional (try $ ws *> skipWS *> quoted) <* skipWS
+    mkPublic pubID = maybe (NotationPubID pubID) (NotationPubSysID pubID)
+
+-- | Parse an external ID.
+externalID :: Parser ExternalID
+externalID = try system <|> public
+  where
+    system = SystemID <$> ("SYSTEM" .*> ws *> skipWS *> quoted)
+    public = PublicID <$> ("PUBLIC" .*> ws *> skipWS *> quoted) <*
+                          ws <* skipWS <*> quoted
+
+-- | Parse a comment
+comment :: Parser Text
+comment = "<!--" .*> (T.concat . concat <$> manyTillS chunk (A.string "--")) <*. ">"
+  where
+    chunk = list2 . T.singleton <$> anyChar <*> takeTill (== '-')
+
+-- | Definition of white space characters, from the XML specification.
+isXMLSpace :: Char -> Bool
+isXMLSpace = (`elem` "\x20\x9\xD\xA")
+
+-- | Parse one character of white space.
+ws :: Parser Char
+ws = satisfy isXMLSpace
+
+-- | Skip zero or more characters of white space
+skipWS :: Parser ()
+skipWS = A.skipWhile isXMLSpace
+
+-- | Type-specialized version of manyTill, so we can use the 'IsString'
+-- instance for 'Parser' 'Text' with it.
+manyTillS :: Parser a -> Parser Text -> Parser [a]
+manyTillS = manyTill
+
+-- | Create a two-element list.
+list2 :: a -> a -> [a]
+list2 x y = [x, y]

+ Data/DTD/Render.hs view

@@ -0,0 +1,239 @@+{-# LANGUAGE OverloadedStrings #-}
+------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.XML.DTD.Render
+-- Copyright   :  Suite Solutions Ltd., Israel 2011
+--
+-- Maintainer  :  Yitzchak Gale <gale@sefer.org>
+-- 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.DTD.Render
+  ( -- * DTD structure
+    buildDTD
+  , buildDTDTextDecl
+  , buildDTDComponent
+
+    -- * Entity declarations and references
+  , buildEntityDecl
+
+    -- * 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.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 ((<>))
+(<>) :: Monoid m => m -> m -> m
+(<>) = 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 -> Builder
+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 "<?xml " <>
+  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 (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, quote $ fromText val)
+      ExternalGeneralEntityDecl   _ eid nt -> (mempty, ege eid nt)
+    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 '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 "--"

+ Data/DTD/Types.hs view

@@ -0,0 +1,107 @@+{-# LANGUAGE DeriveDataTypeable #-}
+module Data.DTD.Types
+  ( -- * DTD structure
+    DTD (..)
+  , DTDTextDecl (..)
+  , DTDComponent (..)
+
+    -- * Entity declarations and references
+  , EntityDecl (..)
+
+    -- * Element declarations
+  , ElementDecl (..)
+  , ContentDecl (..)
+  , ContentModel (..)
+  , Repeat (..)
+
+    -- * Attribute declarations
+  , AttList (..)
+  , AttDecl (..)
+  , AttType (..)
+  , AttDefault (..)
+
+    -- * Notation declarations
+  , Notation (..)
+  , NotationSource (..)
+  )
+  where
+
+import Data.DTD.Types.Unresolved
+    ( DTDTextDecl (..)
+    , ContentModel (..)
+    , Repeat (..)
+    , AttType (..)
+    , AttDefault (..)
+    , Notation (..)
+    , NotationSource (..)
+    )
+import Data.Typeable (Typeable)
+import Data.Text (Text)
+import Data.XML.Types (ExternalID, Instruction)
+
+-- | A list of attribute declarations for an element.
+data AttList =
+     AttList
+       { attListElementName :: Text -- ^ The name of the element to
+                                    -- which the attribute
+                                    -- declarations apply
+       , attListDecls :: [AttDecl]
+       }
+  deriving (Show, Eq, Typeable)
+
+-- | The content that can occur in an element.
+data ContentDecl =
+     ContentEmpty                   -- ^ No content
+   | ContentAny                     -- ^ Unrestricted content
+   | ContentElement ContentModel    -- ^ Structured element content
+   | ContentMixed [Text]            -- ^ A mixture of text and elements
+  deriving (Show, Eq, Typeable)
+
+-- | A declaration of an element.
+data ElementDecl =
+     ElementDecl
+      { eltDeclName :: Text
+      , eltDeclContent :: ContentDecl
+      }
+  deriving (Show, Eq, Typeable)
+
+data EntityDecl =
+     InternalGeneralEntityDecl
+       { entityDeclName :: Text
+       , entityDeclValue :: Text
+       }
+   | ExternalGeneralEntityDecl
+       { entityDeclName :: Text
+       , entityDeclID :: ExternalID
+       , entityDeclNotation :: Maybe Text
+       }                                  -- ^ An external general
+                                          -- entity is unparsed if a
+                                          -- notation is specified.
+  deriving (Show, Eq, Typeable)
+
+-- | The kinds of components that can appear in a 'DTD'.
+data DTDComponent =
+     DTDEntityDecl EntityDecl   -- ^ Entity declaration
+   | DTDElementDecl ElementDecl -- ^ Element declaration
+   | DTDAttList AttList        -- ^ List of attribute declarions for
+                                -- an element
+   | DTDNotation Notation       -- ^ A notation declaration
+   | DTDInstruction Instruction -- ^ A processing instruction
+   | DTDComment Text            -- ^ A comment
+  deriving (Show, Eq, Typeable)
+
+-- | A 'DTD' is a sequence components in any order.
+data DTD = DTD
+             { dtdTextDecl :: Maybe DTDTextDecl
+             , dtdComponents :: [DTDComponent]
+             }
+  deriving (Show, Eq, Typeable)
+
+-- | A declaration of an attribute that can occur in an element.
+data AttDecl =
+     AttDecl
+       { attDeclName :: Text           -- ^ The name of the attribute
+       , attDeclType :: AttType   -- ^ The type of the attribute
+       , attDeclDefault :: AttDefault  -- ^ The default value specification
+       }
+  deriving (Show, Eq)

+ Data/DTD/Types/Unresolved.hs view

@@ -0,0 +1,289 @@+------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.XML.DTD.Types
+-- Copyright   :  Suite Solutions Ltd., Israel 2011
+--
+-- Maintainer  :  Yitzchak Gale <gale@sefer.org>
+-- Portability :  portable
+--
+-- This module provides types to represent an XML Document Type
+-- Declaration (DTD) as defined in W3C specifications
+-- (<http://www.w3.org/XML/Core/#Publications>). It is intended to be
+-- compatible with and extend the set of types in "Data.XML.Types"
+-- provided by the xml-types package.
+--
+-- Following the philosophy of @Data.XML.Types@, the types in this
+-- module are not intended to be a strict and complete representation
+-- of the model in the W3C specifications; rather, they are intended
+-- to be convenient and type-safe for the kinds of processing of DTDs
+-- that are commonly done in practice. As such, this model is
+-- compatible with both Version 1.0 and Version 1.1 of the XML
+-- specification.
+--
+-- Therefore, these types are not suitable for type-level validation
+-- of the syntax of a DTD. For example: these types are more
+-- lenient than the specs about the characters that are allowed in
+-- various locations in a DTD; entities of various kinds only appear
+-- as distinct syntactic elements in places where they are commonly
+-- needed when processing DTDs; etc.
+--
+-- Conditional sections are not represented in these types. They
+-- should be handled directly by parsers and renderers, if needed.
+
+{-
+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.DTD.Types.Unresolved
+  ( -- * DTD structure
+    DTD (..)
+  , DTDTextDecl (..)
+  , DTDComponent (..)
+
+    -- * Entity declarations and references
+  , EntityDecl (..)
+  , EntityValue (..)
+  , PERef
+
+    -- * Element declarations
+  , ElementDecl (..)
+  , ContentDecl (..)
+  , ContentModel (..)
+  , Repeat (..)
+
+    -- * Attribute declarations
+  , AttList (..)
+  , AttDecl (..)
+  , AttDeclPERef (..)
+  , AttType (..)
+  , AttTypePERef (..)
+  , AttDefault (..)
+
+    -- * Notation declarations
+  , Notation (..)
+  , NotationSource (..)
+  ) 
+  where
+
+import Data.Text (Text)
+import Data.Typeable ( Typeable, TypeRep, typeOf
+                     , mkTyConApp, mkTyCon)
+import Data.XML.Types (ExternalID, Instruction)
+
+-- | A 'DTD' is a sequence components in any order.
+data DTD = DTD
+             { dtdTextDecl :: Maybe DTDTextDecl
+             , dtdComponents :: [DTDComponent]
+             }
+  deriving (Show, Eq)
+
+instance Typeable DTD where
+  typeOf = typeString "DTD"
+
+-- | The @?xml@ text declaration at the beginning of a DTD.
+data DTDTextDecl =
+     DTDTextDecl
+       { dtdXMLVersion :: Maybe Text
+       , dtdEncoding :: Text
+       }
+  deriving (Show, Eq)
+
+instance Typeable DTDTextDecl where
+  typeOf = typeString "DTDTextDecl"
+
+-- | The kinds of components that can appear in a 'DTD'.
+data DTDComponent =
+     DTDEntityDecl EntityDecl   -- ^ Entity declaration
+   | DTDElementDecl ElementDecl -- ^ Element declaration
+   | DTDAttList AttList        -- ^ List of attribute declarions for
+                                -- an element
+   | DTDNotation Notation       -- ^ A notation declaration
+   | DTDPERef PERef             -- ^ A parameter entity reference in
+                                -- the top-level flow of the DTD
+   | DTDInstruction Instruction -- ^ A processing instruction
+   | DTDComment Text            -- ^ A comment
+  deriving (Show, Eq)
+
+instance Typeable DTDComponent where
+  typeOf = typeString "DTDComponent"
+
+-- | A declaration of an entity. An entity is a textual substitution
+-- variable. General entities can be referenced in an XML document
+-- conforming to the DTD, and parameter entities can be referenced in
+-- the DTD itself. The value of an unparsed entity is not specified in
+-- the DTD; it is specified by external syntax declared as a notation
+-- elsewhere in the DTD.
+data EntityDecl =
+     InternalGeneralEntityDecl
+       { entityDeclName :: Text
+       , entityDeclValue :: [EntityValue]
+       }
+   | ExternalGeneralEntityDecl
+       { entityDeclName :: Text
+       , entityDeclID :: ExternalID
+       , entityDeclNotation :: Maybe Text
+       }                                  -- ^ An external general
+                                          -- entity is unparsed if a
+                                          -- notation is specified.
+   | InternalParameterEntityDecl
+       { entityDeclName :: Text
+       , entityDeclValue :: [EntityValue]
+       }
+   | ExternalParameterEntityDecl
+       { entityDeclName :: Text
+       , entityDeclID :: ExternalID
+       }
+  deriving (Show, Eq)
+
+instance Typeable EntityDecl where
+  typeOf = typeString "EntityDecl"
+
+-- | The value of an internal entity may contain references to
+-- parameter entities; these references need to be resolved to obtain
+-- the actual replacement value of the entity. So we represent the
+-- value as a mixture of parameter entity references and free text.
+data EntityValue =
+     EntityText Text
+   | EntityPERef PERef
+  deriving (Show, Eq)
+
+instance Typeable EntityValue where
+  typeOf = typeString "EntityValue"
+
+-- | A parameter entity reference. It contains the name of the
+-- parameter entity that is being referenced.
+type PERef = Text
+
+-- | A declaration of an element.
+data ElementDecl =
+     ElementDecl
+      { eltDeclName :: Either PERef Text
+      , eltDeclContent :: ContentDecl
+      }
+  deriving (Show, Eq)
+
+instance Typeable ElementDecl where
+  typeOf = typeString "ElementDecl"
+
+-- | The content that can occur in an element.
+data ContentDecl =
+     ContentEmpty                   -- ^ No content
+   | ContentAny                     -- ^ Unrestricted content
+   | ContentElement [EntityValue]   -- ^ Structured element content
+   | ContentMixed [Text]            -- ^ A mixture of text and elements
+   | ContentPERef PERef
+  deriving (Show, Eq)
+
+instance Typeable ContentDecl where
+  typeOf = typeString "ContentDecl"
+
+-- | A model of structured content for an element.
+data ContentModel =
+     CMName Text Repeat             -- ^ Element name
+   | CMChoice [ContentModel] Repeat -- ^ Choice, delimited by @\"|\"@
+   | CMSeq [ContentModel] Repeat    -- ^ Sequence, delimited by @\",\"@
+  deriving (Show, Eq)
+
+instance Typeable ContentModel where
+  typeOf = typeString "ContentModel"
+
+-- | The number of times a production of content model syntax can
+-- repeat.
+data Repeat = One | ZeroOrOne | ZeroOrMore | OneOrMore
+  deriving (Show, Eq)
+
+instance Typeable Repeat where
+  typeOf = typeString "Repeat"
+
+-- | A list of attribute declarations for an element.
+data AttList =
+     AttList
+       { attListElementName :: Either PERef Text -- ^ The name of the element to
+                                    -- which the attribute
+                                    -- declarations apply
+       , attListDecls :: [AttDeclPERef]
+       }
+  deriving (Show, Eq)
+
+instance Typeable AttList where
+  typeOf = typeString "AttList"
+
+data AttDeclPERef = ADPDecl AttDecl | ADPPERef PERef
+    deriving (Show, Eq)
+
+-- | A declaration of an attribute that can occur in an element.
+data AttDecl =
+     AttDecl
+       { attDeclName :: Text           -- ^ The name of the attribute
+       , attDeclType :: AttTypePERef   -- ^ The type of the attribute
+       , attDeclDefault :: AttDefault  -- ^ The default value specification
+       }
+  deriving (Show, Eq)
+
+instance Typeable AttDecl where
+  typeOf = typeString "AttDecl"
+
+data AttTypePERef = ATPType AttType | ATPPERef PERef
+    deriving (Show, Eq)
+
+-- | The type of value that an attribute can take.
+data AttType =
+     AttStringType           -- ^ Any text
+   | AttIDType               -- ^ A unique ID
+   | AttIDRefType            -- ^ A reference to an ID
+   | AttIDRefsType           -- ^ One or more references to IDs
+   | AttEntityType           -- ^ An unparsed external entity
+   | AttEntitiesType         -- ^ One or more unparsed external entities
+   | AttNmTokenType          -- ^ A name-like token
+   | AttNmTokensType         -- ^ One or more name-like tokens
+   | AttEnumType [Text]      -- ^ One of the given values
+   | AttNotationType [Text]  -- ^ Specified by external syntax
+                             -- declared as a notation
+  deriving (Show, Eq)
+
+instance Typeable AttType where
+  typeOf = typeString "AttType"
+
+-- | A default value specification for an attribute.
+data AttDefault =
+     AttRequired          -- ^ No default value; the attribute must always
+                          -- be supplied
+   | AttImplied           -- ^ No default value; the attribute is optional
+   | AttFixed Text        -- ^ When supplied, the attribute must have the
+                          -- given value
+   | AttDefaultValue Text -- ^ The attribute has the given default value
+                          -- when not supplied
+  deriving (Show, Eq)
+
+instance Typeable AttDefault where
+  typeOf = typeString "AttDefault"
+
+-- | A declaration of a notation.
+data Notation =
+     Notation
+       { notationName :: Text,
+         notationSource :: NotationSource
+       }
+  deriving (Show, Eq)
+
+instance Typeable Notation where
+  typeOf = typeString "Notation"
+
+-- | A source for a notation. We do not use the usual 'ExternalID'
+-- type here, because for notations it is only optional, not required,
+-- for a public ID to be accompanied also by a system ID.
+data NotationSource =
+     NotationSysID Text         -- ^ A system ID
+   | NotationPubID Text         -- ^ A public ID
+   | NotationPubSysID Text Text -- ^ A public ID with a system ID
+  deriving (Show, Eq)
+
+instance Typeable NotationSource where
+  typeOf = typeString "NotationSource"
+
+typeString :: String -> a -> TypeRep
+typeString str _ = mkTyConApp (mkTyCon ("Data.XML.DTD.Types." ++ str)) []

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c)2011, Michael Snoyman
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Michael Snoyman nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.lhs view

@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell
+
+> module Main where
+> import Distribution.Simple
+
+> main :: IO ()
+> main = defaultMain

+ dtd.cabal view

@@ -0,0 +1,37 @@+Name:                dtd
+Version:             0.4.0
+Synopsis:            Parse and render DTD files
+Homepage:            http://github.com/snoyberg/xml
+License:             BSD3
+License-file:        LICENSE
+Author:              Michael Snoyman
+Maintainer:          michaels@suite-sol.com
+Category:            Text
+Build-type:          Simple
+Cabal-version:       >=1.6
+Description:         Parse and render DTD files
+
+Library
+  Exposed-modules:     Data.DTD.Types.Unresolved
+                       Data.DTD.Parse.Unresolved
+                       Data.DTD.Types
+                       Data.DTD.Parse
+                       Data.DTD.Render
+                       Data.DTD.Cache
+  Build-depends:       base                     >= 4          && < 5
+                     , text                     >= 0.11       && < 1.0
+                     , containers               >= 0.2        && < 0.5
+                     , xml-conduit              >= 0.6        && < 0.7
+                     , uri-conduit              >= 0.3        && < 0.4
+                     , transformers             >= 0.2        && < 0.3
+                     , xml-types                >= 0.3        && < 0.4
+                     , attoparsec               >= 0.10       && < 0.11
+                     , monad-control            >= 0.3        && < 0.4
+                     , xml-catalog              >= 0.6        && < 0.7
+                     , blaze-builder            >= 0.3        && < 0.4
+                     , network                  >= 2.2        && < 2.4
+                     , resourcet                >= 0.3        && < 0.4
+                     , conduit                  >= 0.3        && < 0.4
+                     , attoparsec-conduit       >= 0.3        && < 0.4
+                     , lifted-base              >= 0.1        && < 0.2
+  Ghc-options: -Wall