diff --git a/Data/DTD/Parse.hs b/Data/DTD/Parse.hs --- a/Data/DTD/Parse.hs +++ b/Data/DTD/Parse.hs @@ -28,12 +28,12 @@ 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 Data.Conduit.Attoparsec (conduitParser) 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 (liftM, when) import Control.Monad.IO.Class (MonadIO (liftIO)) type ResolveMonad m = ReaderT ResolveReader m @@ -94,7 +94,7 @@ streamUnresolved :: MonadThrow m => Pipe l T.Text [U.DTDComponent] r m r streamUnresolved = - injectLeftovers $ CL.sequence $ sinkParser p + mapOutput snd $ injectLeftovers $ conduitParser p where p = (UP.ws >> UP.skipWS >> return []) <|> (UP.textDecl >> return []) <|> @@ -104,9 +104,7 @@ resolveEnum :: (MonadBaseControl IO m, MonadThrow m, MonadIO m, MonadUnsafeIO m) => ResolveReader -> Pipe l U.DTDComponent DTDComponent r m r -resolveEnum rr = - transPipe (evalStateT' rr) - $ CL.concatMapM resolvef +resolveEnum rr = transPipe (evalStateT' rr) $ awaitForever resolvef evalStateT' :: Monad m => ResolveReader @@ -147,51 +145,50 @@ resolvef :: (MonadBaseControl IO m, MonadThrow m, MonadIO m, MonadUnsafeIO m) => U.DTDComponent - -> ResolveMonad m [DTDComponent] + -> Pipe l U.DTDComponent DTDComponent u (ResolveMonad m) () -- 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.DTDNotation x) = yield $ DTDNotation x +resolvef (U.DTDInstruction x) = yield $ DTDInstruction x +resolvef (U.DTDComment x) = yield $ DTDComment x resolvef (U.DTDEntityDecl (U.ExternalGeneralEntityDecl a b c)) = - return [DTDEntityDecl $ ExternalGeneralEntityDecl a b c] + yield $ DTDEntityDecl $ ExternalGeneralEntityDecl a b c -- look up the EntityValues resolvef (U.DTDEntityDecl (U.InternalGeneralEntityDecl a b)) = do - rs <- get + rs <- lift get case resolveEntityValue rs b of - Left e -> throwError' e - Right t -> return [DTDEntityDecl $ InternalGeneralEntityDecl a t] + Left e -> lift $ throwError' e + Right t -> yield $ 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 [] +resolvef (U.DTDEntityDecl (U.ExternalParameterEntityDecl name eid)) = + lift $ modify $ \rs -> rs { rsRefEid = insertNoReplace name eid $ rsRefEid rs } -- 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 [] + rs <- lift get + t <- either (lift . throwError') return $ resolveEntityValue rs vals + lift $ put $ rs { rsRefText = insertNoReplace name t $ rsRefText rs } -- pull in perefs resolvef (U.DTDPERef p) = do - rs <- get + rs <- lift get case Map.lookup p $ rsRefEid rs of - Nothing -> throwError' $ UnknownPERef p + Nothing -> lift $ throwError' $ UnknownPERef p Just eid -> do - rr <- ask + rr <- lift ask case resolveURI (rrCatalog rr) (Just $ rrBase rr) eid of - Nothing -> throwError' $ CannotResolveExternalID eid + Nothing -> lift $ throwError' $ CannotResolveExternalID eid Just uri -> do let rr' = rr { rrBase = uri } - runResourceT $ readerToEnum rr' $$ CL.consume + x <- lift $ runResourceT $ readerToEnum rr' $$ CL.consume -- FIXME could be more efficient + mapM_ yield x -- element declarations resolvef (U.DTDElementDecl (U.ElementDecl name' c)) = do - name <- either resolvePERefText return name' - c' <- + name <- lift $ either resolvePERefText return name' + c' <- lift $ case c of U.ContentEmpty -> return ContentEmpty U.ContentAny -> return ContentAny @@ -208,14 +205,36 @@ U.ContentElement cm -> resolveContentModel cm U.ContentMixed cm -> return $ ContentMixed cm x -> throwError' $ InvalidContentDecl p t x - return [DTDElementDecl $ ElementDecl name c'] + yield $ 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] + name <- lift $ either resolvePERefText return name' + ys <- lift $ mapM resolveAttDeclPERef xs + yield $ DTDAttList $ AttList name $ concat ys +-- conditional sections +resolvef (U.DTDCondSecBegin x) = do + toInclude <- + case x of + Left peref -> do + value <- lift $ resolvePERefText peref + case value of + "INCLUDE" -> return True + "IGNORE" -> return False + _ -> lift $ throwError' $ InvalidConditionalSectionValue value + Right y -> return y + let loop = await >>= maybe + (lift $ throwError' MissingConditionalSectionEnd) + go + go U.DTDCondSecEnd = return () + go e = do + when toInclude $ resolvef e + loop + loop + +resolvef U.DTDCondSecEnd = lift $ throwError' UnexpectedConditionalSectionEnd + resolveAttDeclPERef :: (MonadIO m, MonadThrow m) => U.AttDeclPERef -> ResolveMonad m [AttDecl] resolveAttDeclPERef (U.ADPDecl (U.AttDecl name typ def)) = do typ' <- @@ -280,6 +299,9 @@ | InvalidAttType U.PERef T.Text (A.Result U.AttType) | RecursiveContentDeclPERef U.PERef | ResolveOther SomeException + | UnexpectedConditionalSectionEnd + | InvalidConditionalSectionValue T.Text + | MissingConditionalSectionEnd deriving (Show, Typeable) instance Exception ResolveException' diff --git a/Data/DTD/Parse/Unresolved.hs b/Data/DTD/Parse/Unresolved.hs --- a/Data/DTD/Parse/Unresolved.hs +++ b/Data/DTD/Parse/Unresolved.hs @@ -135,9 +135,19 @@ , DTDAttList <$> attList , DTDNotation <$> notation , DTDInstruction <$> instruction + , DTDCondSecBegin <$> condSecBegin + , condSecEnd ] ++ -- no try needed for last choice [ DTDComment <$> comment ] + +condSecBegin :: Parser (Either PERef Bool) +condSecBegin = "INCLUDE" .*> pure (Right True) + <|> "IGNORE" .*> pure (Right False) + <|> " (Left <$> pERef) <*. "[" + +condSecEnd :: Parser DTDComponent +condSecEnd = "]]>" .*> return DTDCondSecEnd -- | Parse a processing instruction. instruction :: Parser Instruction 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 @@ -100,6 +100,8 @@ -- the top-level flow of the DTD | DTDInstruction Instruction -- ^ A processing instruction | DTDComment Text -- ^ A comment + | DTDCondSecBegin (Either PERef Bool) + | DTDCondSecEnd deriving (Show, Eq, Typeable) -- | A declaration of an entity. An entity is a textual substitution diff --git a/dtd.cabal b/dtd.cabal --- a/dtd.cabal +++ b/dtd.cabal @@ -1,5 +1,5 @@ Name: dtd -Version: 0.6.0 +Version: 0.6.1 Synopsis: Parse and render DTD files Homepage: http://github.com/snoyberg/xml License: BSD3 @@ -19,18 +19,18 @@ Data.DTD.Render Data.DTD.Cache Build-depends: base >= 4 && < 5 - , text >= 0.11 && < 1.0 + , text >= 0.11 , containers >= 0.2 , xml-conduit >= 1.0 && < 1.1 , uri-conduit >= 0.5 && < 0.6 - , transformers >= 0.2 && < 0.4 + , transformers >= 0.2 , xml-types >= 0.3 && < 0.4 , attoparsec >= 0.10 && < 0.11 , monad-control >= 0.3 && < 0.4 , xml-catalog >= 0.8 && < 0.9 , blaze-builder >= 0.3 && < 0.4 , network >= 2.2 && < 2.4 - , resourcet >= 0.3 && < 0.4 + , resourcet >= 0.3 && < 0.5 , conduit >= 0.5 && < 0.6 , attoparsec-conduit >= 0.5 && < 0.6 , lifted-base >= 0.1 && < 0.2