diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,7 @@ +0.2.0.0 +------- +* Migrate from MonadThrow to MonadError constraint + 0.1.0.1 ------- * Added Cross-reference Streams support diff --git a/Data/Rakhana.hs b/Data/Rakhana.hs --- a/Data/Rakhana.hs +++ b/Data/Rakhana.hs @@ -18,12 +18,14 @@ , NReq , NResp , Number + , NurseryException(..) , Playground , Reference , Stream , Tape , TReq , TResp + , XRefException(..) -- Prisms , _Array , _Boolean diff --git a/Data/Rakhana/Nursery.hs b/Data/Rakhana/Nursery.hs --- a/Data/Rakhana/Nursery.hs +++ b/Data/Rakhana/Nursery.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -------------------------------------------------------------------------------- @@ -16,6 +17,8 @@ ( Playground , NReq , NResp + , NurseryException(..) + , XRefException(..) , nurseryGetInfo , nurseryGetHeader , nurseryGetPages @@ -35,7 +38,7 @@ -------------------------------------------------------------------------------- import Codec.Compression.Zlib (decompress) import Control.Lens -import Control.Monad.Catch +import Control.Monad.Error.Class import Control.Monad.Reader import Control.Monad.State.Strict import Data.Attoparsec.ByteString.Char8 @@ -103,9 +106,6 @@ deriving Show -------------------------------------------------------------------------------- -instance Exception NurseryException - --------------------------------------------------------------------------------- data NurseryState = NurseryState { nurseryHeader :: !Header @@ -120,7 +120,7 @@ bufferSize = 64 -------------------------------------------------------------------------------- -nursery :: MonadCatch m => Nursery m a +nursery :: MonadError NurseryException m => Nursery m a nursery = do h <- getHeader initState <- regularPDFAccess h @@ -135,16 +135,25 @@ dispatch s RqReferences = serveReferences s -------------------------------------------------------------------------------- -regularPDFAccess :: MonadThrow m => Header -> Nursery m NurseryState +regularPDFAccess :: MonadError NurseryException m + => Header + -> Nursery m NurseryState regularPDFAccess h - = do pos <- getXRefPos - xrefE <- getXRef h pos - case xrefE of - Left e -> throwM $ NurseryXRefException e - Right xref -> nurseryState h xref + = do posE <- getXRefPos + case posE of + Left e + -> throwError $ NurseryXRefException e + Right pos + -> do xrefE <- getXRef h pos + case xrefE of + Left e -> throwError $ NurseryXRefException e + Right xref -> nurseryState h xref -------------------------------------------------------------------------------- -nurseryState :: MonadThrow m => Header -> XRef -> Nursery m NurseryState +nurseryState :: MonadError NurseryException m + => Header + -> XRef + -> Nursery m NurseryState nurseryState h xref = do info <- getInfo xref root <- getRoot xref @@ -177,7 +186,7 @@ pages = nurseryPages s -------------------------------------------------------------------------------- -serveResolve :: MonadThrow m +serveResolve :: MonadError NurseryException m => NurseryState -> Reference -> Nursery m (NResp, NurseryState) @@ -188,7 +197,7 @@ xref = nurseryXRef s -------------------------------------------------------------------------------- -serveLoadStream :: MonadThrow m +serveLoadStream :: MonadError NurseryException m => NurseryState -> Stream -> Nursery m (NResp, NurseryState) @@ -199,7 +208,10 @@ xref = nurseryXRef s -------------------------------------------------------------------------------- -loadStream :: MonadThrow m => XRef -> Stream -> Nursery m BL.ByteString +loadStream :: MonadError NurseryException m + => XRef + -> Stream + -> Nursery m BL.ByteString loadStream xref stream = do mLen <- dict ^!? dictKey "Length" . act (resolveIfRef xref) @@ -207,7 +219,7 @@ . _Natural case mLen of Nothing - -> throwM NurseryInvalidStreamObject + -> throwError NurseryInvalidStreamObject Just len -> do driveSeek pos bs <- driveGetLazy $ fromIntegral len @@ -229,11 +241,15 @@ rs = M.keys $ xrefUTable $ nurseryXRef s -------------------------------------------------------------------------------- -getHeader :: MonadThrow m => Nursery m Header -getHeader = driveParse 8 parseHeader +getHeader :: MonadError NurseryException m => Nursery m Header +getHeader + = do hE <- driveParse 8 parseHeader + case hE of + Left e -> throwError $ NurseryParsingException e + Right h -> return h -------------------------------------------------------------------------------- -getInfo :: MonadThrow m => XRef -> Nursery m Dictionary +getInfo :: MonadError NurseryException m => XRef -> Nursery m Dictionary getInfo xref = perform action trailer where trailer = xrefTrailer xref @@ -244,18 +260,18 @@ . _Dict -------------------------------------------------------------------------------- -getRoot :: MonadThrow m => XRef -> Nursery m Root +getRoot :: MonadError NurseryException m => XRef -> Nursery m Root getRoot xref = maybe (trailerRoot xref) (streamRoot xref) xstreamM where xstreamM = xrefStream xref -------------------------------------------------------------------------------- -trailerRoot :: MonadThrow m => XRef -> Nursery m Root +trailerRoot :: MonadError NurseryException m => XRef -> Nursery m Root trailerRoot xref = do mR <- trailer ^!? action case mR of - Nothing -> throwM NurseryRootNotFound + Nothing -> throwError NurseryRootNotFound Just r -> return r where trailer = xrefTrailer xref @@ -267,11 +283,14 @@ . _Dict -------------------------------------------------------------------------------- -streamRoot :: MonadThrow m => XRef -> XRefStream -> Nursery m Root +streamRoot :: MonadError NurseryException m + => XRef + -> XRefStream + -> Nursery m Root streamRoot xref xstream = do mR <- dict ^!? action case mR of - Nothing -> throwM NurseryRootNotFound + Nothing -> throwError NurseryRootNotFound Just r -> return r where dict = xrefStreamDict xstream @@ -283,11 +302,11 @@ . _Dict -------------------------------------------------------------------------------- -getPages :: MonadThrow m => XRef -> Root -> Nursery m Pages +getPages :: MonadError NurseryException m => XRef -> Root -> Nursery m Pages getPages xref root = do mP <- root ^!? action case mP of - Nothing -> throwM NurseryPagesNotFound + Nothing -> throwError NurseryPagesNotFound Just p -> return p where action @@ -297,12 +316,18 @@ . _Dict -------------------------------------------------------------------------------- -resolveIfRef :: MonadThrow m => XRef -> Object -> Nursery m Object +resolveIfRef :: MonadError NurseryException m + => XRef + -> Object + -> Nursery m Object resolveIfRef xref (Ref i g) = resolveObject xref (i,g) resolveIfRef _ obj = return obj -------------------------------------------------------------------------------- -resolveObject :: MonadThrow m => XRef -> Reference -> Nursery m Object +resolveObject :: MonadError NurseryException m + => XRef + -> Reference + -> Nursery m Object resolveObject xref ref = do driveTop driveForward @@ -318,23 +343,23 @@ Just e -> do let offset = uObjOff e driveSeek offset - rE <- driveParseObjectE bufferSize + rE <- driveParseObject bufferSize case rE of - Left e' -> throwM $ NurseryParsingException e' + Left e' -> throwError $ NurseryParsingException e' Right r -> case r ^. _3 of Ref nidx ngen -> loop (nidx,ngen) _ -> return $ r ^. _3 -------------------------------------------------------------------------------- -resolveCompressedObject :: MonadThrow m +resolveCompressedObject :: MonadError NurseryException m => XRef -> Reference -> Nursery m Object resolveCompressedObject xref ref@(idx,gen) = case M.lookup ref centries of Nothing - -> throwM $ NurseryUnresolvedObject idx gen + -> throwError $ NurseryUnresolvedObject idx gen Just cObj -> let objsNum = cObjNum cObj sRef = (objsNum, 0) in @@ -342,12 +367,12 @@ let mPos = sObj ^? _Stream case mPos of Nothing - -> throwM NurseryExpectedStreamObject + -> throwError NurseryExpectedStreamObject Just stream -> do bs <- loadStream xref stream case validateObjStm stream bs of Left e - -> throwM e + -> throwError e Right o -> lookupObjStm ref o where @@ -396,17 +421,20 @@ pos = stream ^. streamPos -------------------------------------------------------------------------------- -lookupObjStm :: MonadThrow m => Reference -> ObjStm -> Nursery m Object +lookupObjStm :: MonadError NurseryException m + => Reference + -> ObjStm + -> Nursery m Object lookupObjStm (idx,_) stm = case M.lookup (fromIntegral idx) reg of - Nothing -> throwM $ NurseryUnresolvedObjectInObjStm idx + Nothing -> throwError $ NurseryUnresolvedObjectInObjStm idx Just off -> do let skipN = fromIntegral (first+off) stream' = BL.drop skipN stream case PL.parse parser stream' of PL.Fail _ _ e - -> throwM $ NurseryParsingExceptionInObjStm e + -> throwError $ NurseryParsingExceptionInObjStm e PL.Done _ obj -> return obj where @@ -417,7 +445,9 @@ first = objStmFirst stm -------------------------------------------------------------------------------- -withNursery :: MonadCatch m => Client' NReq NResp m a -> Drive m a +withNursery :: MonadError NurseryException m + => Client' NReq NResp m a + -> Drive m a withNursery user = nursery >>~ const user -------------------------------------------------------------------------------- diff --git a/Data/Rakhana/Util/Drive.hs b/Data/Rakhana/Util/Drive.hs --- a/Data/Rakhana/Util/Drive.hs +++ b/Data/Rakhana/Util/Drive.hs @@ -20,7 +20,6 @@ -------------------------------------------------------------------------------- import Control.Exception import Control.Lens -import Control.Monad.Catch (MonadThrow(..)) import Data.Attoparsec.ByteString import Pipes.Safe () @@ -36,8 +35,8 @@ instance Exception ParsingException -------------------------------------------------------------------------------- -parseRepeatedly :: Monad m => Int -> Parser a -> Drive m (Either String a) -parseRepeatedly bufferSize parser +driveParse :: Monad m => Int -> Parser a -> Drive m (Either String a) +driveParse bufferSize parser = loop Nothing where loop mK @@ -50,25 +49,11 @@ return $ Right a -------------------------------------------------------------------------------- -driveParse :: MonadThrow m => Int -> Parser a -> Drive m a -driveParse bufSize parser - = do eR <- parseRepeatedly bufSize parser - case eR of - Left e -> throwM $ ParsingException e - Right a -> return a - --------------------------------------------------------------------------------- -driveParseObject :: MonadThrow m => Int -> Drive m (Int, Int, Object) -driveParseObject i - = do rE <- driveParseObjectE i - either (throwM . ParsingException) return rE - --------------------------------------------------------------------------------- -driveParseObjectE :: Monad m - => Int - -> Drive m (Either String (Int, Int, Object)) -driveParseObjectE bufSize - = do rE <- parseRepeatedly bufSize parseIndirectObject +driveParseObject :: Monad m + => Int + -> Drive m (Either String (Int, Int, Object)) +driveParseObject bufSize + = do rE <- driveParse bufSize parseIndirectObject case rE of Left e -> return $ Left e Right r @@ -78,7 +63,7 @@ -> return $ Right r where couldBeStreamObject (idx, gen) d - = do eR <- parseRepeatedly 16 parseStreamHeader + = do eR <- driveParse 16 parseStreamHeader case eR of Left _ -> return $ Right $ (idx, gen, Dict d) diff --git a/Data/Rakhana/XRef.hs b/Data/Rakhana/XRef.hs --- a/Data/Rakhana/XRef.hs +++ b/Data/Rakhana/XRef.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -36,13 +35,11 @@ import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe) import Data.Word -import Data.Typeable -------------------------------------------------------------------------------- import Codec.Compression.Zlib import Codec.Compression.Zlib.Internal import Control.Lens -import Control.Monad.Catch (Exception, MonadThrow(..)) import Control.Monad.State.Strict import Data.Attoparsec.ByteString import qualified Data.Attoparsec.ByteString.Lazy as PL @@ -149,10 +146,7 @@ | UnsupportedFilter B.ByteString | UnsupportedPredictor Integer | ZLibException String String - deriving (Show, Typeable) - --------------------------------------------------------------------------------- -instance Exception XRefException + deriving Show -------------------------------------------------------------------------------- data ExtractState @@ -193,17 +187,21 @@ bufferSize = 4096 -------------------------------------------------------------------------------- -getXRefPos :: MonadThrow m => Drive m Integer +getXRefPos :: Monad m => Drive m (Either XRefException Integer) getXRefPos = do driveBottom driveBackward skipEOL - parseEOF - skipEOL - p <- parseXRefPosInteger - skipEOL - parseStartXRef - return p + mE <- parseEOF + case mE of + Just e + -> return $ Left e + Nothing + -> do skipEOL + p <- parseXRefPosInteger + skipEOL + mR <- parseStartXRef + return $ maybe (Right p) Left mR -------------------------------------------------------------------------------- getXRef :: Monad m => Header -> Integer -> Drive m (Either XRefException XRef) @@ -223,7 +221,7 @@ = do driveTop driveForward driveSeek pos - eR <- parseRepeatedly bufferSize parseXRef + eR <- driveParse bufferSize parseXRef return $ either (Left . XRefParsingException) Right eR -------------------------------------------------------------------------------- @@ -289,7 +287,7 @@ = do driveTop driveForward driveSeek offset - rE <- driveParseObjectE 128 + rE <- driveParseObject 128 case rE of Left e -> return $ Left $ XRefParsingException e Right r -> @@ -555,15 +553,15 @@ _ -> return () -------------------------------------------------------------------------------- -parseEOF :: MonadThrow m => Drive m () +parseEOF :: Monad m => Drive m (Maybe XRefException) parseEOF = do bs <- driveGet 5 case bs of - "%%EOF" -> return () - _ -> throwM $ XRefParsingException "Expected %%EOF" + "%%EOF" -> return Nothing + _ -> return $ Just $ XRefParsingException "Expected %%EOF" -------------------------------------------------------------------------------- -parseXRefPosInteger :: MonadThrow m => Drive m Integer +parseXRefPosInteger :: Monad m => Drive m Integer parseXRefPosInteger = go [] where go cs = do bs <- drivePeek 1 @@ -574,12 +572,13 @@ _ -> return $ read cs -------------------------------------------------------------------------------- -parseStartXRef :: MonadThrow m => Drive m () +parseStartXRef :: Monad m => Drive m (Maybe XRefException) parseStartXRef = do bs <- driveGet 9 case bs of - "startxref" -> return () - _ -> throwM $ XRefParsingException "Expected startxref" + "startxref" -> return Nothing + _ -> return $ Just $ + XRefParsingException "Expected startxref" -------------------------------------------------------------------------------- -- Parsers diff --git a/rakhana.cabal b/rakhana.cabal --- a/rakhana.cabal +++ b/rakhana.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.0.1 +version: 0.2.0.0 -- A short (one-line) description of the package. synopsis: Stream based PDF library @@ -66,8 +66,7 @@ Data.Rakhana.XRef -- LANGUAGE extensions used by modules in this package. - other-extensions: DeriveDataTypeable - FlexibleContexts + other-extensions: FlexibleContexts OverloadedStrings RankNTypes TemplateHaskell @@ -77,7 +76,6 @@ , attoparsec == 0.12.* , bytestring , containers == 0.5.* - , exceptions == 0.6.* , lens == 4.4.* , mtl , pipes == 4.*