aboutsummaryrefslogtreecommitdiff
path: root/src/Text
diff options
context:
space:
mode:
Diffstat (limited to 'src/Text')
-rw-r--r--src/Text/Pandoc/Class.hs202
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)