@@ -1,4 +1,5 @@
1−{-# LANGUAGE DeriveFunctor, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-}
1+{-# LANGUAGE DeriveFunctor, DeriveDataTypeable, TypeSynonymInstances,
2+FlexibleInstances, GeneralizedNewtypeDeriving, FlexibleContexts #-}
23
34{-
45Copyright (C) 2016 Jesse Rosenthal <jrosenthal@jhu.edu>
@@ -31,10 +32,14 @@ Typeclass for pandoc readers and writers, allowing both IO and pure instances.
3132-}
3233
3334module Text.Pandoc.Class ( PandocMonad(..)
34− , Testing
3535 , TestState(..)
3636 , TestEnv(..)
3737 , getPOSIXTime
38+ , PandocIO(..)
39+ , PandocPure(..)
40+ , PandocExecutionError(..)
41+ , runIO
42+ , runIOorExplode
3843 ) where
3944
4045import Prelude hiding (readFile, fail)
@@ -64,10 +69,13 @@ import System.FilePath ((</>))
6469import qualified System.FilePath.Glob as IO (glob)
6570import Control.Monad.State hiding (fail)
6671import Control.Monad.Reader hiding (fail)
72+import Control.Monad.Except hiding (fail)
6773import Data.Word (Word8)
6874import Data.Typeable
75+import Data.Default
76+import System.IO.Error
6977
70−class (Functor m, Applicative m, Monad m) => PandocMonad m where
78+class (Functor m, Applicative m, Monad m, MonadError PandocExecutionError m) => PandocMonad m where
7179 lookupEnv :: String -> m (Maybe String)
7280 getCurrentTime :: m UTCTime
7381 getDefaultReferenceDocx :: Maybe FilePath -> m Archive
@@ -75,14 +83,16 @@ class (Functor m, Applicative m, Monad m) => PandocMonad m where
7583 newStdGen :: m StdGen
7684 newUniqueHash :: m Int
7785 readFileLazy :: FilePath -> m BL.ByteString
78− readDataFile :: Maybe FilePath -> FilePath -> m B.ByteString
79− fetchItem :: Maybe String ->
80− String ->
81− m (Either E.SomeException (B.ByteString, Maybe MimeType))
82− fetchItem' :: MediaBag ->
83− Maybe String ->
84− String ->
85− m (Either E.SomeException (B.ByteString, Maybe MimeType))
86+ readDataFile :: Maybe FilePath
87+ -> FilePath
88+ -> m B.ByteString
89+ fetchItem :: Maybe String
90+ -> String
91+ -> m (Either E.SomeException (B.ByteString, Maybe MimeType))
92+ fetchItem' :: MediaBag
93+ -> Maybe String
94+ -> String
95+ -> m (Either E.SomeException (B.ByteString, Maybe MimeType))
8696 warn :: String -> m ()
8797 fail :: String -> m b
8898 glob :: String -> m [FilePath]
@@ -92,22 +102,55 @@ class (Functor m, Applicative m, Monad m) => PandocMonad m where
92102getPOSIXTime :: (PandocMonad m) => m POSIXTime
93103getPOSIXTime = utcTimeToPOSIXSeconds <$> getCurrentTime
94104
95−instance PandocMonad IO where
96− lookupEnv = IO.lookupEnv
97− getCurrentTime = IO.getCurrentTime
98− getDefaultReferenceDocx = IO.getDefaultReferenceDocx
99− getDefaultReferenceODT = IO.getDefaultReferenceODT
100− newStdGen = IO.newStdGen
101− newUniqueHash = hashUnique <$> IO.newUnique
102− readFileLazy = BL.readFile
103− readDataFile = IO.readDataFile
104− fail = M.fail
105− fetchItem = IO.fetchItem
106− fetchItem' = IO.fetchItem'
107− warn = IO.warn
108− glob = IO.glob
109−
110105
106+-- We can add to this as we go
107+data PandocExecutionError = PandocFileReadError String
108+ deriving Show
109+
110+-- Nothing in this for now, but let's put it there anyway.
111+data PandocStateIO = PandocStateIO
112+ deriving Show
113+
114+instance Default PandocStateIO where
115+ def = PandocStateIO
116+
117+runIO :: PandocIO a -> IO (Either PandocExecutionError a)
118+runIO ma = flip evalStateT def $ runExceptT $ unPandocIO ma
119+
120+runIOorExplode :: PandocIO a -> IO a
121+runIOorExplode ma = do
122+ eitherVal <- runIO ma
123+ case eitherVal of
124+ Right x -> return x
125+ Left (PandocFileReadError s) -> error s
126+
127+newtype PandocIO a = PandocIO {
128+ unPandocIO :: ExceptT PandocExecutionError (StateT PandocStateIO IO) a
129+ } deriving (MonadIO, Functor, Applicative, Monad, MonadError PandocExecutionError)
130+
131+instance PandocMonad PandocIO where
132+ lookupEnv = liftIO . IO.lookupEnv
133+ getCurrentTime = liftIO IO.getCurrentTime
134+ getDefaultReferenceDocx = liftIO . IO.getDefaultReferenceDocx
135+ getDefaultReferenceODT = liftIO . IO.getDefaultReferenceODT
136+ newStdGen = liftIO IO.newStdGen
137+ newUniqueHash = hashUnique <$> (liftIO IO.newUnique)
138+ readFileLazy s = do
139+ eitherBS <- liftIO (tryIOError $ BL.readFile s)
140+ case eitherBS of
141+ Right bs -> return bs
142+ Left _ -> throwError $ PandocFileReadError $ "file not found: " ++ s
143+ -- TODO: Make this more sensitive to the different sorts of failure
144+ readDataFile mfp fname = do
145+ eitherBS <- liftIO (tryIOError $ IO.readDataFile mfp fname)
146+ case eitherBS of
147+ Right bs -> return bs
148+ Left _ -> throwError $ PandocFileReadError $ "file not found: " ++ fname
149+ fail = M.fail
150+ fetchItem ms s = liftIO $ IO.fetchItem ms s
151+ fetchItem' mb ms s = liftIO $ IO.fetchItem' mb ms s
152+ warn = liftIO . IO.warn
153+ glob = liftIO . IO.glob
111154
112155data TestState = TestState { stStdGen :: StdGen
113156 , stWord8Store :: [Word8] -- should be
@@ -136,9 +179,12 @@ data TestException = TestException
136179
137180instance E.Exception TestException
138181
139−type Testing = ReaderT TestEnv (State TestState)
182+newtype PandocPure a = PandocPure {
183+ unPandocPure :: ExceptT PandocExecutionError
184+ (ReaderT TestEnv (State TestState)) a
185+ } deriving (Functor, Applicative, Monad, MonadReader TestEnv, MonadState TestState, MonadError PandocExecutionError)
140186
141−instance PandocMonad Testing where
187+instance PandocMonad PandocPure where
142188 lookupEnv s = do
143189 env <- asks envEnv
144190 return (lookup s env)
@@ -162,13 +208,11 @@ instance PandocMonad Testing where
162208 modify $ \st -> st { stUniqStore = us }
163209 return u
164210 _ -> M.fail "uniq store ran out of elements"
165−
166211 readFileLazy fp = do
167212 fps <- asks envFiles
168213 case lookup fp fps of
169214 Just bs -> return (BL.fromStrict bs)
170− Nothing -> error "openFile: does not exist"
171−
215+ Nothing -> throwError $ PandocFileReadError "file not in state"
172216 readDataFile Nothing "reference.docx" = do
173217 (B.concat . BL.toChunks . fromArchive) <$> (getDefaultReferenceDocx Nothing)
174218 readDataFile Nothing "reference.odt" = do
@@ -181,9 +225,7 @@ instance PandocMonad Testing where
181225 case lookup (userDir </> fname) userDirFiles of
182226 Just bs -> return bs
183227 Nothing -> readDataFile Nothing fname
184−
185228 fail = M.fail
186−
187229 fetchItem _ fp = do
188230 fps <- asks envFiles
189231 case lookup fp fps of