dtd 0.6.0 → 0.6.1
raw patch · 4 files changed
+70/−36 lines, 4 filesdep ~resourcetdep ~textdep ~transformers
Dependency ranges changed: resourcet, text, transformers
Files
- Data/DTD/Parse.hs +54/−32
- Data/DTD/Parse/Unresolved.hs +10/−0
- Data/DTD/Types/Unresolved.hs +2/−0
- dtd.cabal +4/−4
Data/DTD/Parse.hs view
@@ -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'
Data/DTD/Parse/Unresolved.hs view
@@ -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
Data/DTD/Types/Unresolved.hs view
@@ -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
dtd.cabal view
@@ -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