dtd 0.4.1 → 0.5.0
raw patch · 9 files changed
+1566/−1565 lines, 9 filesdep ~attoparsec-conduitdep ~conduitdep ~transformerssetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: attoparsec-conduit, conduit, transformers, uri-conduit, xml-catalog, xml-conduit
API changes (from Hackage documentation)
Files
- Data/DTD/Cache.hs +210/−210
- Data/DTD/Parse.hs +290/−289
- Data/DTD/Parse/Unresolved.hs +357/−357
- Data/DTD/Render.hs +239/−239
- Data/DTD/Types.hs +107/−107
- Data/DTD/Types/Unresolved.hs +289/−289
- LICENSE +30/−30
- Setup.lhs +7/−7
- dtd.cabal +37/−37
Data/DTD/Cache.hs view
@@ -1,210 +1,210 @@-{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -module Data.DTD.Cache - ( DTDCache - , applyDTD - , applyDTD_ - , newDTDCache - , newDTDCacheFile - , loadAttrMap - , UnresolvedEntity (..) - , AttrMap - , EntityMap - , Att (..) - ) 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 +{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+module Data.DTD.Cache+ ( DTDCache+ , applyDTD+ , applyDTD_+ , newDTDCache+ , newDTDCacheFile+ , loadAttrMap+ , UnresolvedEntity (..)+ , AttrMap+ , EntityMap+ , Att (..)+ ) 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
@@ -1,289 +1,290 @@-{-# 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 (C.Open src close x) = C.Open (addCatch src) (addCatch' close) x - addCatch C.Closed = C.Closed - addCatch (C.SourceM msrc close) = C.SourceM (addCatch' $ liftM addCatch msrc) (addCatch' close) - - addCatch' m = m `Lifted.catch` throw rr - -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 +{-# 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.PipeM 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 (C.HaveOutput src close x) = C.HaveOutput (addCatch src) (addCatch' close) x+ addCatch (C.NeedInput _ src) = addCatch src+ addCatch (C.Done l ()) = C.Done l ()+ addCatch (C.PipeM msrc close) = C.PipeM (addCatch' $ liftM addCatch msrc) (addCatch' close)++ addCatch' m = m `Lifted.catch` throw rr++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.PipeM 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.transPipe (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
@@ -1,357 +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] +{-# 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
@@ -1,239 +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 "--" +{-# 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
@@ -1,107 +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) +{-# 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
@@ -1,289 +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)) [] +------------------------------------------------------------------------------+-- |+-- 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
@@ -1,30 +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. +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
@@ -1,7 +1,7 @@-#!/usr/bin/env runhaskell - -> module Main where -> import Distribution.Simple - -> main :: IO () -> main = defaultMain +#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain
dtd.cabal view
@@ -1,37 +1,37 @@-Name: dtd -Version: 0.4.1 -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 +Name: dtd+Version: 0.5.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.7 && < 0.8+ , uri-conduit >= 0.4 && < 0.5+ , transformers >= 0.2 && < 0.4+ , xml-types >= 0.3 && < 0.4+ , attoparsec >= 0.10 && < 0.11+ , monad-control >= 0.3 && < 0.4+ , xml-catalog >= 0.7 && < 0.8+ , blaze-builder >= 0.3 && < 0.4+ , network >= 2.2 && < 2.4+ , resourcet >= 0.3 && < 0.4+ , conduit >= 0.4 && < 0.5+ , attoparsec-conduit >= 0.4 && < 0.5+ , lifted-base >= 0.1 && < 0.2+ Ghc-options: -Wall