diff --git a/Data/DTD/Cache.hs b/Data/DTD/Cache.hs --- a/Data/DTD/Cache.hs +++ b/Data/DTD/Cache.hs @@ -27,7 +27,7 @@ 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 Data.Conduit hiding (Source, Sink, Conduit) import qualified Data.Conduit.List as CL import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Data.IORef as I @@ -90,7 +90,7 @@ 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 + doc <- runResourceT $ readURI sm uri' $$ X.sinkDoc X.def let c = fromDocument doc let includes = (c $// element "{http://www.w3.org/2001/XMLSchema}include" >=> attribute "schemaLocation") ++ @@ -119,7 +119,7 @@ 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 + ecomps <- liftIO $ try $ runResourceT $ readEID catalog (uriToEID uri) sm $$ CL.consume comps <- either (liftIO . throwIO . CannotLoadDTD (toNetworkURI uri)) return ecomps let maps = toMaps comps liftIO $ I.atomicModifyIORef icache $ \m -> @@ -166,7 +166,7 @@ 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' + Right $ X.Element name (Map.fromList $ as'' as') ns' where as'' as' = case Map.lookup name attrs of diff --git a/Data/DTD/Parse.hs b/Data/DTD/Parse.hs --- a/Data/DTD/Parse.hs +++ b/Data/DTD/Parse.hs @@ -25,11 +25,11 @@ 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 Data.Conduit hiding (Source, Sink, Conduit) import qualified Data.Conduit.Internal as CI import Text.XML.Stream.Parse (detectUtf) import Data.Conduit.Attoparsec (sinkParser) -import Control.Applicative ((*>), (<*), (<|>), (<$>), many) +import Control.Applicative ((*>), (<*), (<|>), many) import qualified Data.IORef as I import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.Attoparsec.Text as A @@ -38,58 +38,53 @@ type ResolveMonad m = ReaderT ResolveReader m -readEID :: (C.MonadResource m, MonadBaseControl IO m) +readEID :: (MonadResource m, MonadBaseControl IO m) => Catalog -> ExternalID -> SchemeMap - -> C.Source m DTDComponent + -> Pipe l i DTDComponent u m () 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 + 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 + readerToEnum rr -readerToEnum :: (MonadBaseControl IO m, C.MonadThrow m, MonadIO m, C.MonadResource m) - => ResolveReader -> C.Source m DTDComponent +readerToEnum :: (MonadBaseControl IO m, MonadThrow m, MonadIO m, MonadResource m) + => ResolveReader -> Pipe l i DTDComponent u m () readerToEnum rr = addCatch src0 where src0 = readURI (rrSchemeMap rr) (rrBase rr) - C.$= detectUtf - C.$= streamUnresolved - C.$= CL.concatMap id - C.$= resolveEnum rr + >+> detectUtf + >+> streamUnresolved + >+> CL.concatMap id + >+> 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 :: (MonadThrow m, MonadBaseControl IO m) + => Pipe l i o u m r + -> Pipe l i o u m r + addCatch (CI.HaveOutput src close x) = CI.HaveOutput (addCatch src) (addCatch' close) x + addCatch (CI.NeedInput p c) = CI.NeedInput (addCatch . p) (addCatch . c) + addCatch (CI.Done r) = CI.Done r + addCatch (CI.PipeM msrc) = CI.PipeM (addCatch' $ liftM addCatch msrc) + addCatch (CI.Leftover p i) = CI.Leftover (addCatch p) i 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 :: MonadThrow m => ResolveReader -> SomeException -> m a throw rr e = - C.monadThrow $ OccuredAt (show $ toNetworkURI $ rrBase rr) (ResolveOther e) + monadThrow $ OccuredAt (show $ toNetworkURI $ rrBase rr) (ResolveOther e) readFile_ :: FilePath -> IO [DTDComponent] -readFile_ fp = C.runResourceT $ enumFile fp C.$$ CL.consume +readFile_ fp = runResourceT $ enumFile fp $$ 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] +enumFile :: (MonadBaseControl IO m, MonadResource m) => FilePath -> Pipe l i DTDComponent u m () +enumFile fp = do + eid <- lift $ filePathToEID fp + readEID Map.empty eid $ toSchemeMap [fileScheme] filePathToEID :: MonadIO m => FilePath -> m ExternalID filePathToEID = liftM uriToEID . liftIO . decodeString @@ -97,20 +92,20 @@ uriToEID :: URI -> ExternalID uriToEID = SystemID . T.pack . show . toNetworkURI -streamUnresolved :: C.MonadThrow m => C.Conduit T.Text m [U.DTDComponent] +streamUnresolved :: MonadThrow m => Pipe l T.Text [U.DTDComponent] r m r streamUnresolved = - C.sequenceSink () $ const $ C.Emit () . return <$> sinkParser p + injectLeftovers $ CL.sequence $ 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) +resolveEnum :: (MonadBaseControl IO m, MonadThrow m, MonadIO m, MonadUnsafeIO m) => ResolveReader - -> C.Conduit U.DTDComponent m DTDComponent + -> Pipe l U.DTDComponent DTDComponent r m r resolveEnum rr = - C.transPipe (evalStateT' rr) + transPipe (evalStateT' rr) $ CL.concatMapM resolvef evalStateT' :: Monad m @@ -150,7 +145,7 @@ initState :: ResolveState initState = ResolveState Map.empty Map.empty -resolvef :: (MonadBaseControl IO m, C.MonadThrow m, MonadIO m, C.MonadUnsafeIO m) +resolvef :: (MonadBaseControl IO m, MonadThrow m, MonadIO m, MonadUnsafeIO m) => U.DTDComponent -> ResolveMonad m [DTDComponent] @@ -191,7 +186,7 @@ Nothing -> throwError' $ CannotResolveExternalID eid Just uri -> do let rr' = rr { rrBase = uri } - C.runResourceT $ readerToEnum rr' C.$$ CL.consume + runResourceT $ readerToEnum rr' $$ CL.consume -- element declarations resolvef (U.DTDElementDecl (U.ElementDecl name' c)) = do @@ -221,7 +216,7 @@ ys <- mapM resolveAttDeclPERef xs return [DTDAttList $ AttList name $ concat ys] -resolveAttDeclPERef :: (MonadIO m, C.MonadThrow m) => U.AttDeclPERef -> ResolveMonad m [AttDecl] +resolveAttDeclPERef :: (MonadIO m, MonadThrow m) => U.AttDeclPERef -> ResolveMonad m [AttDecl] resolveAttDeclPERef (U.ADPDecl (U.AttDecl name typ def)) = do typ' <- case typ of @@ -238,16 +233,16 @@ 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' :: MonadThrow m => ResolveException' -> ResolveMonad m a throwError' e = do uri <- liftM rrBase ask - lift $ C.monadThrow $ OccuredAt (show $ toNetworkURI uri) e + lift $ 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 :: (MonadIO m, MonadThrow m) => U.PERef -> ResolveMonad m T.Text resolvePERefText p = do rs <- get maybe (throwError' $ UnknownPERefText p) return $ Map.lookup p $ rsRefText rs @@ -262,7 +257,7 @@ Nothing -> Left $ UnknownPERefValue p Just t -> Right t -resolveContentModel :: (MonadIO m, C.MonadThrow m) => [U.EntityValue] -> ResolveMonad m ContentDecl +resolveContentModel :: (MonadIO m, MonadThrow m) => [U.EntityValue] -> ResolveMonad m ContentDecl resolveContentModel ev = do rs <- get text <- either throwError' return $ resolveEntityValue rs ev diff --git a/Data/DTD/Render.hs b/Data/DTD/Render.hs --- a/Data/DTD/Render.hs +++ b/Data/DTD/Render.hs @@ -135,9 +135,8 @@ where name = fromText (entityDeclName d) <> space (pct, val) = case d of - InternalGeneralEntityDecl _ val -> (mempty, quote $ fromText val) + 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 diff --git a/Data/DTD/Types/Unresolved.hs b/Data/DTD/Types/Unresolved.hs --- a/Data/DTD/Types/Unresolved.hs +++ b/Data/DTD/Types/Unresolved.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} ------------------------------------------------------------------------------ -- | -- Module : Data.XML.DTD.Types @@ -70,8 +71,7 @@ where import Data.Text (Text) -import Data.Typeable ( Typeable, TypeRep, typeOf - , mkTyConApp, mkTyCon) +import Data.Typeable (Typeable) import Data.XML.Types (ExternalID, Instruction) -- | A 'DTD' is a sequence components in any order. @@ -79,10 +79,7 @@ { dtdTextDecl :: Maybe DTDTextDecl , dtdComponents :: [DTDComponent] } - deriving (Show, Eq) - -instance Typeable DTD where - typeOf = typeString "DTD" + deriving (Show, Eq, Typeable) -- | The @?xml@ text declaration at the beginning of a DTD. data DTDTextDecl = @@ -90,10 +87,7 @@ { dtdXMLVersion :: Maybe Text , dtdEncoding :: Text } - deriving (Show, Eq) - -instance Typeable DTDTextDecl where - typeOf = typeString "DTDTextDecl" + deriving (Show, Eq, Typeable) -- | The kinds of components that can appear in a 'DTD'. data DTDComponent = @@ -106,10 +100,7 @@ -- 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" + deriving (Show, Eq, Typeable) -- | A declaration of an entity. An entity is a textual substitution -- variable. General entities can be referenced in an XML document @@ -137,10 +128,7 @@ { entityDeclName :: Text , entityDeclID :: ExternalID } - deriving (Show, Eq) - -instance Typeable EntityDecl where - typeOf = typeString "EntityDecl" + deriving (Show, Eq, Typeable) -- | The value of an internal entity may contain references to -- parameter entities; these references need to be resolved to obtain @@ -149,10 +137,7 @@ data EntityValue = EntityText Text | EntityPERef PERef - deriving (Show, Eq) - -instance Typeable EntityValue where - typeOf = typeString "EntityValue" + deriving (Show, Eq, Typeable) -- | A parameter entity reference. It contains the name of the -- parameter entity that is being referenced. @@ -164,10 +149,7 @@ { eltDeclName :: Either PERef Text , eltDeclContent :: ContentDecl } - deriving (Show, Eq) - -instance Typeable ElementDecl where - typeOf = typeString "ElementDecl" + deriving (Show, Eq, Typeable) -- | The content that can occur in an element. data ContentDecl = @@ -176,28 +158,19 @@ | 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" + deriving (Show, Eq, Typeable) -- | 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" + deriving (Show, Eq, Typeable) -- | 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" + deriving (Show, Eq, Typeable) -- | A list of attribute declarations for an element. data AttList = @@ -207,10 +180,7 @@ -- declarations apply , attListDecls :: [AttDeclPERef] } - deriving (Show, Eq) - -instance Typeable AttList where - typeOf = typeString "AttList" + deriving (Show, Eq, Typeable) data AttDeclPERef = ADPDecl AttDecl | ADPPERef PERef deriving (Show, Eq) @@ -222,10 +192,7 @@ , attDeclType :: AttTypePERef -- ^ The type of the attribute , attDeclDefault :: AttDefault -- ^ The default value specification } - deriving (Show, Eq) - -instance Typeable AttDecl where - typeOf = typeString "AttDecl" + deriving (Show, Eq, Typeable) data AttTypePERef = ATPType AttType | ATPPERef PERef deriving (Show, Eq) @@ -243,10 +210,7 @@ | 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" + deriving (Show, Eq, Typeable) -- | A default value specification for an attribute. data AttDefault = @@ -257,10 +221,7 @@ -- given value | AttDefaultValue Text -- ^ The attribute has the given default value -- when not supplied - deriving (Show, Eq) - -instance Typeable AttDefault where - typeOf = typeString "AttDefault" + deriving (Show, Eq, Typeable) -- | A declaration of a notation. data Notation = @@ -268,10 +229,7 @@ { notationName :: Text, notationSource :: NotationSource } - deriving (Show, Eq) - -instance Typeable Notation where - typeOf = typeString "Notation" + deriving (Show, Eq, Typeable) -- | A source for a notation. We do not use the usual 'ExternalID' -- type here, because for notations it is only optional, not required, @@ -280,10 +238,4 @@ 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)) [] + deriving (Show, Eq, Typeable) diff --git a/dtd.cabal b/dtd.cabal --- a/dtd.cabal +++ b/dtd.cabal @@ -1,5 +1,5 @@ Name: dtd -Version: 0.5.1.1 +Version: 0.6.0 Synopsis: Parse and render DTD files Homepage: http://github.com/snoyberg/xml License: BSD3 @@ -21,17 +21,17 @@ Build-depends: base >= 4 && < 5 , text >= 0.11 && < 1.0 , containers >= 0.2 - , xml-conduit >= 0.7 && < 0.8 - , uri-conduit >= 0.4 && < 0.5 + , xml-conduit >= 1.0 && < 1.1 + , uri-conduit >= 0.5 && < 0.6 , 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 + , xml-catalog >= 0.8 && < 0.9 , 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 + , conduit >= 0.5 && < 0.6 + , attoparsec-conduit >= 0.5 && < 0.6 , lifted-base >= 0.1 && < 0.2 Ghc-options: -Wall