Introduce PandocMonad typeclass.

This can be instantiated by both an IO monad or a pure State monad.

1 files changed, 202 insertions, 0 deletions

diff --git a/src/Text/Pandoc/Class.hs b/src/Text/Pandoc/Class.hs
new file mode 100644
index 000000000..aca1067c6
--- /dev/null
+++ b/src/Text/Pandoc/Class.hs
@@ -0,0 +1,202 @@
+{-# LANGUAGE DeriveFunctor, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-}
+
+{-
+Copyright (C) 2016 Jesse Rosenthal <jrosenthal@jhu.edu>
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+-}
+
+{- |
+   Module      : Text.Pandoc.Class
+   Copyright   : Copyright (C) 2016 Jesse Rosenthal
+   License     : GNU GPL, version 2 or above
+
+   Maintainer  : Jesse Rosenthal <jrosenthal@jhu.edu>
+   Stability   : alpha
+   Portability : portable
+
+Typeclass for pandoc readers and writers, allowing both IO and pure instances.
+-}
+
+module Text.Pandoc.Class ( PandocMonad(..)
+                         , Testing
+                         , TestState(..)
+                         , TestEnv(..)
+                         , getPOSIXTime
+                         ) where
+
+import Prelude hiding (readFile, fail)
+import qualified Control.Monad as M (fail)
+import System.Random (StdGen, next)
+import qualified System.Random as IO (newStdGen)
+import Codec.Archive.Zip (Archive, fromArchive)
+import Data.Unique (hashUnique)
+import qualified Data.Unique as IO (newUnique)
+import qualified Text.Pandoc.Shared as IO ( fetchItem
+                                          , fetchItem'
+                                          , getDefaultReferenceDocx
+                                          , getDefaultReferenceODT
+                                          , warn
+                                          , readDataFile)
+import Text.Pandoc.MediaBag (MediaBag, lookupMedia)
+import Text.Pandoc.Compat.Time (UTCTime)
+import qualified Text.Pandoc.Compat.Time as IO (getCurrentTime)
+import Data.Time.Clock.POSIX ( utcTimeToPOSIXSeconds, POSIXTime )
+import Text.Pandoc.MIME (MimeType, getMimeType)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as BL
+import qualified Control.Exception as E
+import qualified System.Environment as IO (lookupEnv)
+import System.FilePath.Glob (match, compile)
+import System.FilePath ((</>))
+import qualified System.FilePath.Glob as IO (glob)
+import Control.Monad.State hiding (fail)
+import Control.Monad.Reader hiding (fail)
+import Data.Word (Word8)
+import Data.Typeable
+
+class Monad m => PandocMonad m where
+  lookupEnv :: String -> m (Maybe String)
+  getCurrentTime :: m UTCTime
+  getDefaultReferenceDocx :: Maybe FilePath -> m Archive
+  getDefaultReferenceODT :: Maybe FilePath -> m Archive
+  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))
+  warn :: String -> m ()
+  fail :: String -> m b
+  glob :: String -> m [FilePath]
+
+--Some functions derived from Primitives:
+
+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
+
+
+
+data TestState = TestState { stStdGen     :: StdGen
+                           , stWord8Store :: [Word8] -- should be
+                                                     -- inifinite,
+                                                     -- i.e. [1..]
+                           , stWarnings   :: [String]
+                           , stUniqStore  :: [Int] -- should be
+                                                   -- inifinite and
+                                                   -- contain every
+                                                   -- element at most
+                                                   -- once, e.g. [1..]
+                           }
+
+data TestEnv = TestEnv { envEnv :: [(String, String)]
+                       , envTime :: UTCTime
+                       , envReferenceDocx :: Archive
+                       , envReferenceODT :: Archive
+                       , envFiles :: [(FilePath, B.ByteString)]
+                       , envUserDataDir :: [(FilePath, B.ByteString)]
+                       , envCabalDataDir :: [(FilePath, B.ByteString)]
+                       , envFontFiles :: [FilePath]
+                       }
+
+data TestException = TestException
+  deriving (Show, Typeable)
+
+instance E.Exception TestException
+
+type Testing = ReaderT TestEnv (State TestState)
+
+instance PandocMonad Testing where
+  lookupEnv s = do
+    env <- asks envEnv
+    return (lookup s env)
+
+  getCurrentTime = asks envTime
+
+  getDefaultReferenceDocx _ = asks envReferenceDocx
+
+  getDefaultReferenceODT _ = asks envReferenceODT
+
+  newStdGen = do
+    g <- gets stStdGen
+    let (_, nxtGen) = next g
+    modify $ \st -> st { stStdGen = nxtGen }
+    return g
+
+  newUniqueHash = do
+    uniqs <- gets stUniqStore
+    case uniqs of
+      u : us -> do
+        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"
+
+  readDataFile Nothing "reference.docx" = do
+    (B.concat . BL.toChunks . fromArchive) <$> (getDefaultReferenceDocx Nothing)
+  readDataFile Nothing "reference.odt" = do
+    (B.concat . BL.toChunks . fromArchive) <$> (getDefaultReferenceODT Nothing)
+  readDataFile Nothing fname = do
+    let fname' = if fname == "MANUAL.txt" then fname else "data" </> fname
+    BL.toStrict <$> (readFileLazy fname')
+  readDataFile (Just userDir) fname = do
+    userDirFiles <- asks envUserDataDir
+    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
+      Just bs -> return (Right (bs, getMimeType fp))
+      Nothing -> return (Left $ E.toException TestException)
+
+  fetchItem' media sourceUrl nm = do
+    case lookupMedia nm media of
+      Nothing -> fetchItem sourceUrl nm
+      Just (mime, bs) -> return (Right (B.concat $ BL.toChunks bs, Just mime))
+
+  warn s =  modify $ \st -> st { stWarnings = s : stWarnings st }
+
+  glob s = do
+    fontFiles <- asks envFontFiles
+    return (filter (match (compile s)) fontFiles)