dtd 0.5.0 → 0.5.1
raw patch · 9 files changed
+1571/−1566 lines, 9 filesdep ~conduitsetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: conduit
API changes (from Hackage documentation)
Files
- Data/DTD/Cache.hs +210/−210
- Data/DTD/Parse.hs +295/−290
- 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,290 +1,295 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-module Data.DTD.Parse- ( readFile_- , enumFile- , filePathToEID- , uriToEID- , readEID- ) where--import Data.DTD.Types-import Data.XML.Types (ExternalID (SystemID))-import qualified Data.DTD.Types.Unresolved as U-import qualified Data.DTD.Parse.Unresolved as UP-import Control.Exception (Exception, SomeException, throwIO)-import qualified Control.Exception.Lifted as Lifted-import qualified Data.Conduit.List as CL-import Control.Monad.Trans.Class (MonadTrans, lift)-import qualified Data.Text as T-import qualified Data.Map as Map-import Data.Typeable (Typeable)-import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)-import Text.XML.Catalog (resolveURI, Catalog)-import Network.URI.Conduit (URI, SchemeMap, readURI, toNetworkURI, toSchemeMap)-import Network.URI.Conduit.File (decodeString, fileScheme)-import qualified Data.Conduit as C-import Text.XML.Stream.Parse (detectUtf)-import Data.Conduit.Attoparsec (sinkParser)-import Control.Applicative ((*>), (<*), (<|>), (<$>), many)-import qualified Data.IORef as I-import Control.Monad.Trans.Control (MonadBaseControl)-import qualified Data.Attoparsec.Text as A-import Control.Monad (liftM)-import Control.Monad.IO.Class (MonadIO (liftIO))--type ResolveMonad m = ReaderT ResolveReader m--readEID :: (C.MonadResource m, MonadBaseControl IO m)- => Catalog- -> ExternalID- -> SchemeMap- -> C.Source m DTDComponent-readEID catalog eid sm =- C.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+{-# 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 qualified Data.Conduit.Internal as CI +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 + + addCatch'' (CI.FinalizeM m) = CI.FinalizeM $ m `Lifted.catch` throw rr + addCatch'' (CI.FinalizePure x) = CI.FinalizePure x + +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.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+Name: dtd +Version: 0.5.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.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.1.1 && < 0.5 + , attoparsec-conduit >= 0.4 && < 0.5 + , lifted-base >= 0.1 && < 0.2 + Ghc-options: -Wall