aboutsummaryrefslogtreecommitdiff
path: root/src/Text/Pandoc/Class.hs
blob: 69d2bb7616627bcbd07103f042391858e8e70d1d (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
{-# LANGUAGE DeriveFunctor, DeriveDataTypeable, TypeSynonymInstances,
FlexibleInstances, GeneralizedNewtypeDeriving, FlexibleContexts #-}

{-
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(..)
                         , TestState(..)
                         , TestEnv(..)
                         , getPOSIXTime
                         , PandocIO(..)
                         , PandocPure(..)
                         , PandocExecutionError(..)
                         , runIO
                         , runIOorExplode
                         , runPure
                         ) where

import Prelude hiding (readFile, fail)
import qualified Control.Monad as M (fail)
import System.Random (StdGen, next, mkStdGen)
import qualified System.Random as IO (newStdGen)
import Codec.Archive.Zip (Archive, fromArchive, emptyArchive)
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
                             , posixSecondsToUTCTime
                             , 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 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, MonadError PandocExecutionError 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


-- We can add to this as we go
data PandocExecutionError = PandocFileReadError FilePath
                          | PandocShouldNeverHappenError String
                          | PandocSomeError String
                          deriving (Show, Typeable)

-- 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 fp) -> error $ "promple reading " ++ fp
    Left (PandocShouldNeverHappenError s) -> error s
    Left (PandocSomeError 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 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 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
                                                     -- inifinite,
                                                     -- i.e. [1..]
                           , stWarnings   :: [String]
                           , stUniqStore  :: [Int] -- should be
                                                   -- inifinite and
                                                   -- contain every
                                                   -- element at most
                                                   -- once, e.g. [1..]
                           }

instance Default TestState where
  def = TestState { stStdGen = mkStdGen 1848
                  , stWord8Store = [1..]
                  , stWarnings = []
                  , stUniqStore = [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]
                       }

-- We have to figure this out a bit more. But let's put some empty
-- values in for the time being.
instance Default TestEnv where
  def = TestEnv { envEnv = [("USER", "pandoc-user")]
                , envTime = posixSecondsToUTCTime 0
                , envReferenceDocx = emptyArchive
                , envReferenceODT = emptyArchive
                , envFiles = []
                , envUserDataDir = []
                , envCabalDataDir = []
                , envFontFiles = []
                }

instance E.Exception PandocExecutionError

newtype PandocPure a = PandocPure {
  unPandocPure :: ExceptT PandocExecutionError
                  (ReaderT TestEnv (State TestState)) a
  } deriving (Functor, Applicative, Monad, MonadReader TestEnv, MonadState TestState, MonadError PandocExecutionError)

runPure :: PandocPure a -> Either PandocExecutionError a
runPure x = flip evalState def $ flip runReaderT def $ runExceptT $ unPandocPure x

instance PandocMonad PandocPure 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 -> throwError $ PandocFileReadError fp
  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 $ PandocFileReadError fp)

  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)