aboutsummaryrefslogtreecommitdiff
path: root/src/Text/Pandoc
diff options
context:
space:
mode:
authorJesse Rosenthal <jrosenthal@jhu.edu>2016-11-24 09:54:18 -0500
committerJohn MacFarlane <jgm@berkeley.edu>2017-01-25 17:07:39 +0100
commita94f3dddee60360b8ba6a18ac2633fce2104cf02 (patch)
treeab59a7694990769ffe40fc66d294ae83f5d9c4c9 /src/Text/Pandoc
parent45f3c53dd9d540abac958b13783677c263aa6658 (diff)
downloadpandoc-a94f3dddee60360b8ba6a18ac2633fce2104cf02.tar.gz
Make opaque typeclasses PandocPure and PandocIO
Diffstat (limited to 'src/Text/Pandoc')
-rw-r--r--src/Text/Pandoc/Class.hs108
1 files changed, 75 insertions, 33 deletions
diff --git a/src/Text/Pandoc/Class.hs b/src/Text/Pandoc/Class.hs
index 2f5d179fe..f7915b27d 100644
--- a/src/Text/Pandoc/Class.hs
+++ b/src/Text/Pandoc/Class.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE DeriveFunctor, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE DeriveFunctor, DeriveDataTypeable, TypeSynonymInstances,
+FlexibleInstances, GeneralizedNewtypeDeriving, FlexibleContexts #-}
{-
Copyright (C) 2016 Jesse Rosenthal <jrosenthal@jhu.edu>
@@ -31,10 +32,14 @@ Typeclass for pandoc readers and writers, allowing both IO and pure instances.
-}
module Text.Pandoc.Class ( PandocMonad(..)
- , Testing
, TestState(..)
, TestEnv(..)
, getPOSIXTime
+ , PandocIO(..)
+ , PandocPure(..)
+ , PandocExecutionError(..)
+ , runIO
+ , runIOorExplode
) where
import Prelude hiding (readFile, fail)
@@ -64,10 +69,13 @@ import System.FilePath ((</>))
import qualified System.FilePath.Glob as IO (glob)
import Control.Monad.State hiding (fail)
import Control.Monad.Reader hiding (fail)
+import Control.Monad.Except hiding (fail)
import Data.Word (Word8)
import Data.Typeable
+import Data.Default
+import System.IO.Error
-class (Functor m, Applicative m, Monad m) => PandocMonad m where
+class (Functor m, Applicative m, Monad m, MonadError PandocExecutionError m) => PandocMonad m where
lookupEnv :: String -> m (Maybe String)
getCurrentTime :: m UTCTime
getDefaultReferenceDocx :: Maybe FilePath -> m Archive
@@ -75,14 +83,16 @@ class (Functor m, Applicative m, Monad m) => PandocMonad m where
newStdGen :: m StdGen
newUniqueHash :: m Int
readFileLazy :: FilePath -> m BL.ByteString
- readDataFile :: Maybe FilePath -> FilePath -> m B.ByteString
- fetchItem :: Maybe String ->
- String ->
- m (Either E.SomeException (B.ByteString, Maybe MimeType))
- fetchItem' :: MediaBag ->
- Maybe String ->
- String ->
- m (Either E.SomeException (B.ByteString, Maybe MimeType))
+ readDataFile :: Maybe FilePath
+ -> FilePath
+ -> m B.ByteString
+ fetchItem :: Maybe String
+ -> String
+ -> m (Either E.SomeException (B.ByteString, Maybe MimeType))
+ fetchItem' :: MediaBag
+ -> Maybe String
+ -> String
+ -> m (Either E.SomeException (B.ByteString, Maybe MimeType))
warn :: String -> m ()
fail :: String -> m b
glob :: String -> m [FilePath]
@@ -92,22 +102,55 @@ class (Functor m, Applicative m, Monad m) => PandocMonad m where
getPOSIXTime :: (PandocMonad m) => m POSIXTime
getPOSIXTime = utcTimeToPOSIXSeconds <$> getCurrentTime
-instance PandocMonad IO where
- lookupEnv = IO.lookupEnv
- getCurrentTime = IO.getCurrentTime
- getDefaultReferenceDocx = IO.getDefaultReferenceDocx
- getDefaultReferenceODT = IO.getDefaultReferenceODT
- newStdGen = IO.newStdGen
- newUniqueHash = hashUnique <$> IO.newUnique
- readFileLazy = BL.readFile
- readDataFile = IO.readDataFile
- fail = M.fail
- fetchItem = IO.fetchItem
- fetchItem' = IO.fetchItem'
- warn = IO.warn
- glob = IO.glob
-
+-- We can add to this as we go
+data PandocExecutionError = PandocFileReadError String
+ deriving Show
+
+-- Nothing in this for now, but let's put it there anyway.
+data PandocStateIO = PandocStateIO
+ deriving Show
+
+instance Default PandocStateIO where
+ def = PandocStateIO
+
+runIO :: PandocIO a -> IO (Either PandocExecutionError a)
+runIO ma = flip evalStateT def $ runExceptT $ unPandocIO ma
+
+runIOorExplode :: PandocIO a -> IO a
+runIOorExplode ma = do
+ eitherVal <- runIO ma
+ case eitherVal of
+ Right x -> return x
+ Left (PandocFileReadError s) -> error s
+
+newtype PandocIO a = PandocIO {
+ unPandocIO :: ExceptT PandocExecutionError (StateT PandocStateIO IO) a
+ } deriving (MonadIO, Functor, Applicative, Monad, MonadError PandocExecutionError)
+
+instance PandocMonad PandocIO where
+ lookupEnv = liftIO . IO.lookupEnv
+ getCurrentTime = liftIO IO.getCurrentTime
+ getDefaultReferenceDocx = liftIO . IO.getDefaultReferenceDocx
+ getDefaultReferenceODT = liftIO . IO.getDefaultReferenceODT
+ newStdGen = liftIO IO.newStdGen
+ newUniqueHash = hashUnique <$> (liftIO IO.newUnique)
+ readFileLazy s = do
+ eitherBS <- liftIO (tryIOError $ BL.readFile s)
+ case eitherBS of
+ Right bs -> return bs
+ Left _ -> throwError $ PandocFileReadError $ "file not found: " ++ s
+ -- TODO: Make this more sensitive to the different sorts of failure
+ readDataFile mfp fname = do
+ eitherBS <- liftIO (tryIOError $ IO.readDataFile mfp fname)
+ case eitherBS of
+ Right bs -> return bs
+ Left _ -> throwError $ PandocFileReadError $ "file not found: " ++ fname
+ fail = M.fail
+ fetchItem ms s = liftIO $ IO.fetchItem ms s
+ fetchItem' mb ms s = liftIO $ IO.fetchItem' mb ms s
+ warn = liftIO . IO.warn
+ glob = liftIO . IO.glob
data TestState = TestState { stStdGen :: StdGen
, stWord8Store :: [Word8] -- should be
@@ -136,9 +179,12 @@ data TestException = TestException
instance E.Exception TestException
-type Testing = ReaderT TestEnv (State TestState)
+newtype PandocPure a = PandocPure {
+ unPandocPure :: ExceptT PandocExecutionError
+ (ReaderT TestEnv (State TestState)) a
+ } deriving (Functor, Applicative, Monad, MonadReader TestEnv, MonadState TestState, MonadError PandocExecutionError)
-instance PandocMonad Testing where
+instance PandocMonad PandocPure where
lookupEnv s = do
env <- asks envEnv
return (lookup s env)
@@ -162,13 +208,11 @@ instance PandocMonad Testing where
modify $ \st -> st { stUniqStore = us }
return u
_ -> M.fail "uniq store ran out of elements"
-
readFileLazy fp = do
fps <- asks envFiles
case lookup fp fps of
Just bs -> return (BL.fromStrict bs)
- Nothing -> error "openFile: does not exist"
-
+ Nothing -> throwError $ PandocFileReadError "file not in state"
readDataFile Nothing "reference.docx" = do
(B.concat . BL.toChunks . fromArchive) <$> (getDefaultReferenceDocx Nothing)
readDataFile Nothing "reference.odt" = do
@@ -181,9 +225,7 @@ instance PandocMonad Testing where
case lookup (userDir </> fname) userDirFiles of
Just bs -> return bs
Nothing -> readDataFile Nothing fname
-
fail = M.fail
-
fetchItem _ fp = do
fps <- asks envFiles
case lookup fp fps of