@@ -1,269 +0,0 @@
1−{-# LANGUAGE DeriveFunctor, DeriveDataTypeable #-}
2−
3−{-
4−Copyright (C) 2016 Jesse Rosenthal <jrosenthal@jhu.edu>
5−
6−This program is free software; you can redistribute it and/or modify
7−it under the terms of the GNU General Public License as published by
8−the Free Software Foundation; either version 2 of the License, or
9−(at your option) any later version.
10−
11−This program is distributed in the hope that it will be useful,
12−but WITHOUT ANY WARRANTY; without even the implied warranty of
13−MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14−GNU General Public License for more details.
15−
16−You should have received a copy of the GNU General Public License
17−along with this program; if not, write to the Free Software
18−Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
19−-}
20−
21−{- |
22− Module : Text.Pandoc.Free
23− Copyright : Copyright (C) 2016 Jesse Rosenthal
24− License : GNU GPL, version 2 or above
25−
26− Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>
27− Stability : alpha
28− Portability : portable
29−
30−Pure implementations of the IO monads used in Pandoc's readers and writers.
31−-}
32−
33−module Text.Pandoc.Free ( PandocActionF(..)
34− , PandocAction
35− , runIO
36− , runTest
37− , TestState(..)
38− , TestEnv(..)
39− , liftF
40− --
41− , lookupEnv
42− , getCurrentTime
43− , getPOSIXTime
44− , getDefaultReferenceDocx
45− , getDefaultReferenceODT
46− , newStdGen
47− , newUniqueHash
48− , readFileLazy
49− , readDataFile
50− , fetchItem
51− , fetchItem'
52− , warn
53− , fail
54− , glob
55− ) where
56−
57−import Prelude hiding (readFile, fail)
58−import qualified Control.Monad as M (fail)
59−import System.Random (StdGen, next)
60−import qualified System.Random as IO (newStdGen)
61−import Codec.Archive.Zip (Archive, fromArchive)
62−import Data.Unique (hashUnique)
63−import qualified Data.Unique as IO (newUnique)
64−import qualified Text.Pandoc.Shared as IO ( fetchItem
65− , fetchItem'
66− , getDefaultReferenceDocx
67− , getDefaultReferenceODT
68− , warn
69− , readDataFile)
70−import Text.Pandoc.MediaBag (MediaBag, lookupMedia)
71−import Text.Pandoc.Compat.Time (UTCTime)
72−import qualified Text.Pandoc.Compat.Time as IO (getCurrentTime)
73−import Data.Time.Clock.POSIX ( utcTimeToPOSIXSeconds, POSIXTime )
74−import Text.Pandoc.MIME (MimeType, getMimeType)
75−import qualified Data.ByteString as B
76−import qualified Data.ByteString.Lazy as BL
77−import Control.Monad.Free
78−import qualified Control.Exception as E
79−import qualified System.Environment as IO (lookupEnv)
80−import System.FilePath.Glob (match, compile)
81−import System.FilePath ((</>))
82−import qualified System.FilePath.Glob as IO (glob)
83−import Control.Monad.State hiding (fail)
84−import Control.Monad.Reader hiding (fail)
85−import Data.Word (Word8)
86−import Data.Typeable
87−
88−data PandocActionF nxt =
89− LookupEnv String (Maybe String -> nxt)
90− | GetCurrentTime (UTCTime -> nxt)
91− | GetDefaultReferenceDocx (Maybe FilePath) (Archive -> nxt)
92− | GetDefaultReferenceODT (Maybe FilePath) (Archive -> nxt)
93− | NewStdGen (StdGen -> nxt)
94− | NewUniqueHash (Int -> nxt)
95− | ReadFileLazy FilePath (BL.ByteString -> nxt)
96− | ReadDataFile (Maybe FilePath) FilePath (B.ByteString -> nxt)
97− | FetchItem (Maybe String) (String)
98− (Either E.SomeException (B.ByteString, Maybe MimeType) -> nxt)
99− | FetchItem' MediaBag (Maybe String) (String)
100− (Either E.SomeException (B.ByteString, Maybe MimeType) -> nxt)
101− | Glob String ([FilePath] -> nxt)
102− | Warn String nxt
103− | Fail String
104− deriving Functor
105−
106−type PandocAction = Free PandocActionF
107−
108−lookupEnv :: String -> PandocAction (Maybe String)
109−lookupEnv s = liftF $ LookupEnv s id
110−
111−getCurrentTime :: PandocAction UTCTime
112−getCurrentTime = liftF $ GetCurrentTime id
113−
114−getPOSIXTime :: PandocAction POSIXTime
115−getPOSIXTime = utcTimeToPOSIXSeconds <$> getCurrentTime
116−
117−getDefaultReferenceDocx :: Maybe FilePath -> PandocAction Archive
118−getDefaultReferenceDocx fp = liftF $ GetDefaultReferenceDocx fp id
119−
120−getDefaultReferenceODT :: Maybe FilePath -> PandocAction Archive
121−getDefaultReferenceODT fp = liftF $ GetDefaultReferenceODT fp id
122−
123−newStdGen :: PandocAction StdGen
124−newStdGen = liftF $ NewStdGen id
125−
126−newUniqueHash :: PandocAction Int
127−newUniqueHash = liftF $ NewUniqueHash id
128−
129−readFileLazy :: FilePath -> PandocAction BL.ByteString
130−readFileLazy fp = liftF $ ReadFileLazy fp id
131−
132−readDataFile :: Maybe FilePath -> FilePath -> PandocAction B.ByteString
133−readDataFile mfp fp = liftF $ ReadDataFile mfp fp id
134−
135−fetchItem :: Maybe String ->
136− String ->
137− PandocAction (Either E.SomeException (B.ByteString, Maybe MimeType))
138−fetchItem ms s = liftF $ FetchItem ms s id
139−
140−
141−fetchItem' :: MediaBag ->
142− Maybe String ->
143− String ->
144− PandocAction (Either E.SomeException (B.ByteString, Maybe MimeType))
145−fetchItem' mb ms s = liftF $ FetchItem' mb ms s id
146−
147−warn :: String -> PandocAction ()
148−warn s = liftF $ Warn s ()
149−
150−fail :: String -> PandocAction b
151−fail s = liftF $ Fail s
152−
153−glob :: String -> PandocAction [FilePath]
154−glob s = liftF $ Glob s id
155−
156−runIO :: PandocAction nxt -> IO nxt
157−runIO (Free (LookupEnv s f)) = IO.lookupEnv s >>= runIO . f
158−runIO (Free (GetCurrentTime f)) = IO.getCurrentTime >>= runIO . f
159−runIO (Free (GetDefaultReferenceDocx mfp f)) =
160− IO.getDefaultReferenceDocx mfp >>= runIO . f
161−runIO (Free (GetDefaultReferenceODT mfp f)) =
162− IO.getDefaultReferenceODT mfp >>= runIO . f
163−runIO (Free (NewStdGen f)) = IO.newStdGen >>= runIO . f
164−runIO (Free (NewUniqueHash f)) = hashUnique <$> IO.newUnique >>= runIO . f
165−runIO (Free (ReadFileLazy fp f)) = BL.readFile fp >>= runIO . f
166−runIO (Free (ReadDataFile mfp fp f)) = IO.readDataFile mfp fp >>= runIO . f
167−runIO (Free (Fail s)) = M.fail s
168−runIO (Free (FetchItem sourceUrl nm f)) =
169− IO.fetchItem sourceUrl nm >>= runIO . f
170−runIO (Free (FetchItem' media sourceUrl nm f)) =
171− IO.fetchItem' media sourceUrl nm >>= runIO . f
172−runIO (Free (Warn s nxt)) = IO.warn s >> runIO nxt
173−runIO (Free (Glob s f)) = IO.glob s >>= runIO . f
174−runIO (Pure r) = return r
175−
176−data TestState = TestState { stStdGen :: StdGen
177− , stWord8Store :: [Word8] -- should be
178− -- inifinite,
179− -- i.e. [1..]
180− , stWarnings :: [String]
181− , stUniqStore :: [Int] -- should be
182− -- inifinite and
183− -- contain every
184− -- element at most
185− -- once, e.g. [1..]
186− }
187−
188−data TestEnv = TestEnv { envEnv :: [(String, String)]
189− , envTime :: UTCTime
190− , envReferenceDocx :: Archive
191− , envReferenceODT :: Archive
192− , envFiles :: [(FilePath, B.ByteString)]
193− , envUserDataDir :: [(FilePath, B.ByteString)]
194− , envCabalDataDir :: [(FilePath, B.ByteString)]
195− , envFontFiles :: [FilePath]
196− }
197−
198−data TestException = TestException
199− deriving (Show, Typeable)
200−
201−instance E.Exception TestException
202−
203−type Testing = ReaderT TestEnv (State TestState)
204−
205−runTest :: PandocAction nxt -> Testing nxt
206−runTest (Free (LookupEnv s f)) = do
207− env <- asks envEnv
208− return (lookup s env) >>= runTest . f
209−runTest (Free (GetCurrentTime f)) =
210− asks envTime >>= runTest . f
211−runTest (Free (GetDefaultReferenceDocx _ f)) =
212− asks envReferenceDocx >>= runTest . f
213−runTest (Free (GetDefaultReferenceODT _ f)) =
214− asks envReferenceODT >>= runTest . f
215−runTest (Free (NewStdGen f)) = do
216− g <- gets stStdGen
217− let (_, nxtGen) = next g
218− modify $ \st -> st { stStdGen = nxtGen }
219− return g >>= runTest . f
220−runTest (Free (NewUniqueHash f)) = do
221− uniqs <- gets stUniqStore
222− case uniqs of
223− u : us -> do
224− modify $ \st -> st { stUniqStore = us }
225− return u >>= runTest . f
226− _ -> M.fail "uniq store ran out of elements"
227−runTest (Free (ReadFileLazy fp f)) = do
228− fps <- asks envFiles
229− case lookup fp fps of
230− Just bs -> return (BL.fromStrict bs) >>= runTest . f
231− Nothing -> error "openFile: does not exist"
232−-- A few different cases of readDataFile to reimplement, for when
233−-- there is no filepath and it falls through to readDefaultDataFile
234−runTest (Free (ReadDataFile Nothing "reference.docx" f)) = do
235− (B.concat . BL.toChunks . fromArchive) <$>
236− (runTest $ getDefaultReferenceDocx Nothing) >>=
237− runTest . f
238−runTest (Free (ReadDataFile Nothing "reference.odt" f)) = do
239− (B.concat . BL.toChunks . fromArchive) <$>
240− (runTest $ getDefaultReferenceODT Nothing) >>=
241− runTest . f
242−runTest (Free (ReadDataFile Nothing fname f)) = do
243− let fname' = if fname == "MANUAL.txt" then fname else "data" </> fname
244− runTest (BL.toStrict <$> readFileLazy fname') >>= runTest . f
245−runTest (Free (ReadDataFile (Just userDir) fname f)) = do
246− userDirFiles <- asks envUserDataDir
247− case lookup (userDir </> fname) userDirFiles of
248− Just bs -> return bs >>= runTest . f
249− Nothing -> runTest (readDataFile Nothing fname) >>= runTest . f
250−runTest (Free (Fail s)) = M.fail s
251−runTest (Free (FetchItem _ fp f)) = do
252− fps <- asks envFiles
253− case lookup fp fps of
254− Just bs -> return (Right (bs, getMimeType fp)) >>= runTest . f
255− Nothing -> return (Left $ E.toException TestException) >>= runTest . f
256−runTest (Free (FetchItem' media sourceUrl nm f)) = do
257− case lookupMedia nm media of
258− Nothing -> runTest (fetchItem sourceUrl nm) >>= runTest . f
259− Just (mime, bs) -> return (Right (B.concat $ BL.toChunks bs, Just mime)) >>= runTest . f
260−runTest (Free (Warn s nxt)) = do
261− modify $ \st -> st { stWarnings = s : stWarnings st }
262− runTest nxt
263−runTest (Free (Glob s f)) = do
264− fontFiles <- asks envFontFiles
265− return (filter (match (compile s)) fontFiles) >>= runTest . f
266−runTest (Pure r) = return r
267−
268−
269−