git.iko.soy/typeable/pandoc
on master help sign in
Have a common state for all PandocMonad instances.
4fe499dJesse Rosenthal
src/Text/Pandoc/Class.hs+63−81
compare with master
unifiedsplit
@@ -36,6 +36,13 @@ module Text.Pandoc.Class ( PandocMonad(..)
36 , PureEnv(..)
36 , PureEnv(..)
37 , getPOSIXTime
37 , getPOSIXTime
38 , getZonedTime
38 , getZonedTime
39+ , warn
40+ , getWarnings
41+ , getMediaBag
42+ , setMediaBag
43+ , insertMedia
44+ , getInputFiles
45+ , getOutputFile
39 , addWarningWithPos
46 , addWarningWithPos
40 , PandocIO(..)
47 , PandocIO(..)
41 , PandocPure(..)
48 , PandocPure(..)
@@ -57,7 +64,6 @@ import qualified Text.Pandoc.Shared as IO ( fetchItem
57 , fetchItem'
64 , fetchItem'
58 , getDefaultReferenceDocx
65 , getDefaultReferenceDocx
59 , getDefaultReferenceODT
66 , getDefaultReferenceODT
60− , warn
61 , readDataFile)
67 , readDataFile)
62import Text.Pandoc.Compat.Time (UTCTime)
68import Text.Pandoc.Compat.Time (UTCTime)
63import Text.Pandoc.Parsing (ParserT, ParserState, SourcePos)
69import Text.Pandoc.Parsing (ParserT, ParserState, SourcePos)
@@ -87,7 +93,7 @@ import System.IO.Error
87import qualified Data.Map as M
93import qualified Data.Map as M
88import Text.Pandoc.Error
94import Text.Pandoc.Error
89
95
90−class (Functor m, Applicative m, Monad m, MonadError PandocError m) => PandocMonad m where
96+class (Functor m, Applicative m, Monad m, MonadError PandocError m, MonadState CommonState m) => PandocMonad m where
91 lookupEnv :: String -> m (Maybe String)
97 lookupEnv :: String -> m (Maybe String)
92 getCurrentTime :: m UTCTime
98 getCurrentTime :: m UTCTime
93 getCurrentTimeZone :: m TimeZone
99 getCurrentTimeZone :: m TimeZone
@@ -106,24 +112,44 @@ class (Functor m, Applicative m, Monad m, MonadError PandocError m) => PandocMon
106 -> Maybe String
112 -> Maybe String
107 -> String
113 -> String
108 -> m (Either E.SomeException (B.ByteString, Maybe MimeType))
114 -> m (Either E.SomeException (B.ByteString, Maybe MimeType))
109− warn :: String -> m ()
110− getWarnings :: m [String]
111 fail :: String -> m b
115 fail :: String -> m b
112 glob :: String -> m [FilePath]
116 glob :: String -> m [FilePath]
113 getModificationTime :: FilePath -> m UTCTime
117 getModificationTime :: FilePath -> m UTCTime
114 -- The following are common to all instantiations of the monad, up
118 -- The following are common to all instantiations of the monad, up
115 -- to the record names, so I'd like to work out a better way to deal
119 -- to the record names, so I'd like to work out a better way to deal
116 -- with it.
120 -- with it.
117− setMediaBag :: MediaBag -> m ()
118− getMediaBag :: m MediaBag
119− insertMedia :: FilePath -> Maybe MimeType -> BL.ByteString -> m ()
120− getInputFiles :: m (Maybe [FilePath])
121− getOutputFile :: m (Maybe FilePath)
122
121
123
122
124
123
125--Some functions derived from Primitives:
124--Some functions derived from Primitives:
126
125
126+warn :: PandocMonad m => String -> m ()
127+warn msg = modify $ \st -> st{stWarnings = msg : stWarnings st}
128+
129+getWarnings :: PandocMonad m => m [String]
130+getWarnings = gets stWarnings
131+
132+setMediaBag :: PandocMonad m => MediaBag -> m ()
133+setMediaBag mb = modify $ \st -> st{stMediaBag = mb}
134+
135+getMediaBag :: PandocMonad m => m MediaBag
136+getMediaBag = gets stMediaBag
137+
138+insertMedia :: PandocMonad m => FilePath -> Maybe MimeType -> BL.ByteString -> m ()
139+insertMedia fp mime bs =
140+ modify $ \st -> st{stMediaBag = MB.insertMedia fp mime bs (stMediaBag st) }
141+
142+getInputFiles :: PandocMonad m => m (Maybe [FilePath])
143+getInputFiles = gets stInputFiles
144+
145+getOutputFile :: PandocMonad m => m (Maybe FilePath)
146+getOutputFile = gets stOutputFile
147+
148+
149+
150+
151+
152+
127getPOSIXTime :: (PandocMonad m) => m POSIXTime
153getPOSIXTime :: (PandocMonad m) => m POSIXTime
128getPOSIXTime = utcTimeToPOSIXSeconds <$> getCurrentTime
154getPOSIXTime = utcTimeToPOSIXSeconds <$> getCurrentTime
129
155
@@ -142,27 +168,23 @@ addWarningWithPos mbpos msg =
142 warn $
168 warn $
143 msg ++ maybe "" (\pos -> " " ++ show pos) mbpos
169 msg ++ maybe "" (\pos -> " " ++ show pos) mbpos
144
170
145−
171+data CommonState = CommonState { stWarnings :: [String]
146−-- Nothing in this for now, but let's put it there anyway.
147−data PandocStateIO = PandocStateIO { ioStWarnings :: [String]
148− , ioStMediaBag :: MediaBag
172+ , stMediaBag :: MediaBag
149− } deriving Show
173+ , stInputFiles :: Maybe [FilePath]
150−
151−instance Default PandocStateIO where
152− def = PandocStateIO { ioStWarnings = []
153− , ioStMediaBag = mempty
154− }
155−
156−data PandocEnvIO = PandocEnvIO { ioEnvInputFiles :: Maybe [FilePath]
157− , ioEnvOutputFile :: Maybe FilePath
174+ , stOutputFile :: Maybe FilePath
158 }
175 }
176+
159−instance Default PandocEnvIO where
177+instance Default CommonState where
160− def = PandocEnvIO { ioEnvInputFiles = Nothing -- stdin
178+ def = CommonState { stWarnings = []
161− , ioEnvOutputFile = Nothing -- stdout
179+ , stMediaBag = mempty
180+ , stInputFiles = Nothing
181+ , stOutputFile = Nothing
162 }
182 }
163
183
184+-- Nothing in this for now, but let's put it there anyway.
185+
164runIO :: PandocIO a -> IO (Either PandocError a)
186runIO :: PandocIO a -> IO (Either PandocError a)
165−runIO ma = flip evalStateT def $ flip runReaderT def $ runExceptT $ unPandocIO ma
187+runIO ma = flip evalStateT def $ runExceptT $ unPandocIO ma
166
188
167withMediaBag :: PandocMonad m => m a -> m (a, MediaBag)
189withMediaBag :: PandocMonad m => m a -> m (a, MediaBag)
168withMediaBag ma = ((,)) <$> ma <*> getMediaBag
190withMediaBag ma = ((,)) <$> ma <*> getMediaBag
@@ -177,18 +199,14 @@ runIOorExplode ma = handleError <$> runIO ma
177 -- Left (PandocParseError s) -> error $ "parse error" ++ s
199 -- Left (PandocParseError s) -> error $ "parse error" ++ s
178 -- Left (PandocSomeError s) -> error s
200 -- Left (PandocSomeError s) -> error s
179
201
180−
181−
182−
183
202
184newtype PandocIO a = PandocIO {
203newtype PandocIO a = PandocIO {
185− unPandocIO :: ExceptT PandocError (ReaderT PandocEnvIO (StateT PandocStateIO IO)) a
204+ unPandocIO :: ExceptT PandocError (StateT CommonState IO) a
186 } deriving ( MonadIO
205 } deriving ( MonadIO
187 , Functor
206 , Functor
188 , Applicative
207 , Applicative
189 , Monad
208 , Monad
190− , MonadReader PandocEnvIO
191− , MonadState PandocStateIO
209+ , MonadState CommonState
192 , MonadError PandocError
210 , MonadError PandocError
193 )
211 )
194
212
@@ -214,48 +232,29 @@ instance PandocMonad PandocIO where
214 fail = M.fail
232 fail = M.fail
215 fetchItem ms s = liftIO $ IO.fetchItem ms s
233 fetchItem ms s = liftIO $ IO.fetchItem ms s
216 fetchItem' mb ms s = liftIO $ IO.fetchItem' mb ms s
234 fetchItem' mb ms s = liftIO $ IO.fetchItem' mb ms s
217− warn msg = do
218− modify $ \st -> st{ioStWarnings = msg : ioStWarnings st}
219− liftIO $ IO.warn msg
220− getWarnings = gets ioStWarnings
221 glob = liftIO . IO.glob
235 glob = liftIO . IO.glob
222 getModificationTime fp = do
236 getModificationTime fp = do
223 eitherMtime <- liftIO (tryIOError $ IO.getModificationTime fp)
237 eitherMtime <- liftIO (tryIOError $ IO.getModificationTime fp)
224 case eitherMtime of
238 case eitherMtime of
225 Right mtime -> return mtime
239 Right mtime -> return mtime
226 Left _ -> throwError $ PandocFileReadError fp
240 Left _ -> throwError $ PandocFileReadError fp
227− -- Common functions
228− setMediaBag mb =
229− modify $ \st -> st{ioStMediaBag = mb}
230− getMediaBag = gets ioStMediaBag
231− insertMedia fp mime bs =
232− modify $ \st -> st{ioStMediaBag = MB.insertMedia fp mime bs (ioStMediaBag st) }
233− getInputFiles = asks ioEnvInputFiles
234− getOutputFile = asks ioEnvOutputFile
235−
236
241
237
242
238data PureState = PureState { stStdGen :: StdGen
243data PureState = PureState { stStdGen :: StdGen
239 , stWord8Store :: [Word8] -- should be
244 , stWord8Store :: [Word8] -- should be
240 -- inifinite,
245 -- inifinite,
241 -- i.e. [1..]
246 -- i.e. [1..]
242− , stWarnings :: [String]
243 , stUniqStore :: [Int] -- should be
247 , stUniqStore :: [Int] -- should be
244 -- inifinite and
248 -- inifinite and
245 -- contain every
249 -- contain every
246 -- element at most
250 -- element at most
247 -- once, e.g. [1..]
251 -- once, e.g. [1..]
248− , stMediaBag :: MediaBag
249 }
252 }
250
253
251instance Default PureState where
254instance Default PureState where
252 def = PureState { stStdGen = mkStdGen 1848
255 def = PureState { stStdGen = mkStdGen 1848
253 , stWord8Store = [1..]
256 , stWord8Store = [1..]
254− , stWarnings = []
255 , stUniqStore = [1..]
257 , stUniqStore = [1..]
256− , stMediaBag = mempty
257−
258−
259 }
258 }
260data FileInfo = FileInfo { infoFileMTime :: UTCTime
259data FileInfo = FileInfo { infoFileMTime :: UTCTime
261 , infoFileContents :: B.ByteString
260 , infoFileContents :: B.ByteString
@@ -276,8 +275,6 @@ data PureEnv = PureEnv { envEnv :: [(String, String)]
276 , envUserDataDir :: FileTree
275 , envUserDataDir :: FileTree
277 , envCabalDataDir :: FileTree
276 , envCabalDataDir :: FileTree
278 , envFontFiles :: [FilePath]
277 , envFontFiles :: [FilePath]
279− , envInputFiles :: Maybe [FilePath]
280− , envOutputFile :: Maybe FilePath
281 }
278 }
282
279
283-- We have to figure this out a bit more. But let's put some empty
280-- We have to figure this out a bit more. But let's put some empty
@@ -292,23 +289,25 @@ instance Default PureEnv where
292 , envUserDataDir = mempty
289 , envUserDataDir = mempty
293 , envCabalDataDir = mempty
290 , envCabalDataDir = mempty
294 , envFontFiles = []
291 , envFontFiles = []
295− , envInputFiles = Nothing
296− , envOutputFile = Nothing
297 }
292 }
298
293
299newtype PandocPure a = PandocPure {
294newtype PandocPure a = PandocPure {
300 unPandocPure :: ExceptT PandocError
295 unPandocPure :: ExceptT PandocError
301− (ReaderT PureEnv (State PureState)) a
296+ (ReaderT PureEnv (StateT CommonState (State PureState))) a
302 } deriving ( Functor
297 } deriving ( Functor
303 , Applicative
298 , Applicative
304 , Monad
299 , Monad
305 , MonadReader PureEnv
300 , MonadReader PureEnv
306− , MonadState PureState
301+ , MonadState CommonState
307 , MonadError PandocError
302 , MonadError PandocError
308 )
303 )
309
304
310runPure :: PandocPure a -> Either PandocError a
305runPure :: PandocPure a -> Either PandocError a
311−runPure x = flip evalState def $ flip runReaderT def $ runExceptT $ unPandocPure x
306+runPure x = flip evalState def $
307+ flip evalStateT def $
308+ flip runReaderT def $
309+ runExceptT $
310+ unPandocPure x
312
311
313instance PandocMonad PandocPure where
312instance PandocMonad PandocPure where
314 lookupEnv s = do
313 lookupEnv s = do
@@ -323,17 +322,17 @@ instance PandocMonad PandocPure where
323
322
324 getDefaultReferenceODT _ = asks envReferenceODT
323 getDefaultReferenceODT _ = asks envReferenceODT
325
324
326− newStdGen = do
325+ newStdGen = PandocPure $ do
327− g <- gets stStdGen
326+ g <- lift $ lift $ lift $ gets stStdGen
328 let (_, nxtGen) = next g
327 let (_, nxtGen) = next g
329− modify $ \st -> st { stStdGen = nxtGen }
328+ lift $ lift $ lift $ modify $ \st -> st { stStdGen = nxtGen }
330 return g
329 return g
331
330
332− newUniqueHash = do
331+ newUniqueHash = PandocPure $ do
333− uniqs <- gets stUniqStore
332+ uniqs <- lift $ lift $ lift $ gets stUniqStore
334 case uniqs of
333 case uniqs of
335 u : us -> do
334 u : us -> do
336− modify $ \st -> st { stUniqStore = us }
335+ lift $ lift $ lift $ modify $ \st -> st { stUniqStore = us }
337 return u
336 return u
338 _ -> M.fail "uniq store ran out of elements"
337 _ -> M.fail "uniq store ran out of elements"
339 readFileLazy fp = do
338 readFileLazy fp = do
@@ -365,10 +364,6 @@ instance PandocMonad PandocPure where
365 Nothing -> fetchItem sourceUrl nm
364 Nothing -> fetchItem sourceUrl nm
366 Just (mime, bs) -> return (Right (B.concat $ BL.toChunks bs, Just mime))
365 Just (mime, bs) -> return (Right (B.concat $ BL.toChunks bs, Just mime))
367
366
368− warn s = modify $ \st -> st { stWarnings = s : stWarnings st }
369−
370− getWarnings = gets stWarnings
371−
372 glob s = do
367 glob s = do
373 fontFiles <- asks envFontFiles
368 fontFiles <- asks envFontFiles
374 return (filter (match (compile s)) fontFiles)
369 return (filter (match (compile s)) fontFiles)
@@ -379,19 +374,6 @@ instance PandocMonad PandocPure where
379 Just tm -> return tm
374 Just tm -> return tm
380 Nothing -> throwError $ PandocFileReadError fp
375 Nothing -> throwError $ PandocFileReadError fp
381
376
382− -- Common files
383−
384− setMediaBag mb =
385− modify $ \st -> st{stMediaBag = mb}
386−
387− getMediaBag = gets stMediaBag
388−
389− insertMedia fp mime bs =
390− modify $ \st -> st{stMediaBag = MB.insertMedia fp mime bs (stMediaBag st) }
391−
392− getInputFiles = asks envInputFiles
393−
394− getOutputFile = asks envOutputFile
395
377
396
378
397
379