Tissevert/pandoc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions 1

Implement runTest functions.

Browse source 
These work with a State monad and a Reader monad to produce
deterministic results. It can probably be simplified somewhat.
This commit is contained in:
Jesse Rosenthal 2016-11-16 20:49:17 -05:00 • committed by John MacFarlane
parent 072107d1a2
commit e24d5a56a7
7 changed files with 176 additions and 84 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
pandoc.cabal
View file

@ -290,7 +290,7 @@ Library
old-time,
deepseq >= 1.3 && < 1.5,
JuicyPixels >= 3.1.6.1 && < 3.3,
filemanip >= 0.3 && < 0.4,
Glob >= 0.7 && < 0.8,
cmark >= 0.5 && < 0.6,
doctemplates >= 0.1 && < 0.2,
free >= 4

215
src/Text/Pandoc/Free.hs
View file

@ -33,6 +33,7 @@ Pure implementations of the IO monads used in Pandoc's readers and writers.
module Text.Pandoc.Free ( PandocActionF(..)
, PandocAction
, runIO
, runTest
, liftF
--
, lookupEnv
@ -41,7 +42,7 @@ module Text.Pandoc.Free ( PandocActionF(..)
, getDefaultReferenceDocx
, getDefaultReferenceODT
, newStdGen
, newUnique
, newUniqueHash
, newUUID
, readFileStrict
, readFileLazy
@ -51,18 +52,15 @@ module Text.Pandoc.Free ( PandocActionF(..)
, fetchItem'
, warn
, fail
, newIORef
, modifyIORef
, readIORef
, namesMatching
, glob
) where
import Prelude hiding (readFile, fail)
import qualified Control.Monad as M (fail)
import System.Random (StdGen)
import System.Random (StdGen, next)
import qualified System.Random as IO (newStdGen)
import Codec.Archive.Zip (Archive)
import Data.Unique (Unique)
import Codec.Archive.Zip (Archive, fromArchive)
import Data.Unique (Unique, hashUnique, newUnique)
import qualified Data.Unique as IO (newUnique)
import qualified Text.Pandoc.Shared as IO ( fetchItem
, fetchItem'
@ -70,32 +68,35 @@ import qualified Text.Pandoc.Shared as IO ( fetchItem
, getDefaultReferenceODT
, warn
, readDataFile)
import Text.Pandoc.MediaBag (MediaBag)
import Data.Time.Clock.POSIX (POSIXTime)
import Text.Pandoc.MediaBag (MediaBag, lookupMedia)
import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds)
import qualified Data.Time.Clock.POSIX as IO (getPOSIXTime)
import Text.Pandoc.Compat.Time (UTCTime)
import qualified Text.Pandoc.Compat.Time as IO (getCurrentTime)
import Text.Pandoc.MIME (MimeType)
import Text.Pandoc.MIME (MimeType, getMimeType)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Control.Monad.Free
import qualified Control.Exception as E
import qualified System.Environment as IO (lookupEnv)
import Data.IORef (IORef)
import qualified Data.IORef as IO (newIORef, modifyIORef, readIORef)
import Text.Pandoc.UUID (UUID)
import Text.Pandoc.UUID
import qualified Text.Pandoc.UUID as IO (getRandomUUID)
import qualified Text.Pandoc.UTF8 as UTF8 (readFile)
import qualified System.FilePath.Glob as IO (namesMatching)
import qualified Text.Pandoc.UTF8 as UTF8 (readFile, toString)
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)
data PandocActionF ref nxt =
data PandocActionF nxt =
LookupEnv String (Maybe String -> nxt)
| GetCurrentTime (UTCTime -> nxt)
| GetPOSIXTime (POSIXTime -> nxt)
| GetDefaultReferenceDocx (Maybe FilePath) (Archive -> nxt)
| GetDefaultReferenceODT (Maybe FilePath) (Archive -> nxt)
| NewStdGen (StdGen -> nxt)
| NewUnique (Unique -> nxt)
| NewUniqueHash (Int -> nxt)
| NewUUID (UUID -> nxt)
| ReadFileStrict FilePath (B.ByteString -> nxt)
| ReadFileLazy FilePath (BL.ByteString -> nxt)
@ -105,83 +106,71 @@ data PandocActionF ref nxt =
(Either E.SomeException (B.ByteString, Maybe MimeType) -> nxt)
| FetchItem' MediaBag (Maybe String) (String)
(Either E.SomeException (B.ByteString, Maybe MimeType) -> nxt)
| NewIORef ref (IORef ref -> nxt)
| ModifyIORef (IORef ref) (ref -> ref) nxt
| ReadIORef (IORef ref) (ref -> nxt)
| NamesMatching String ([FilePath] -> nxt)
| Glob String ([FilePath] -> nxt)
| Warn String nxt
| Fail String
deriving Functor
type PandocAction a = Free (PandocActionF a)
type PandocAction = Free PandocActionF
lookupEnv :: String -> PandocAction a (Maybe String)
lookupEnv :: String -> PandocAction (Maybe String)
lookupEnv s = liftF $ LookupEnv s id
getCurrentTime :: PandocAction a UTCTime
getCurrentTime :: PandocAction UTCTime
getCurrentTime = liftF $ GetCurrentTime id
getPOSIXTime :: PandocAction a POSIXTime
getPOSIXTime :: PandocAction POSIXTime
getPOSIXTime = liftF $ GetPOSIXTime id
getDefaultReferenceDocx :: Maybe FilePath -> PandocAction a Archive
getDefaultReferenceDocx :: Maybe FilePath -> PandocAction Archive
getDefaultReferenceDocx fp = liftF $ GetDefaultReferenceDocx fp id
getDefaultReferenceODT :: Maybe FilePath -> PandocAction a Archive
getDefaultReferenceODT :: Maybe FilePath -> PandocAction Archive
getDefaultReferenceODT fp = liftF $ GetDefaultReferenceODT fp id
newStdGen :: PandocAction a StdGen
newStdGen :: PandocAction StdGen
newStdGen = liftF $ NewStdGen id
newUnique :: PandocAction a Unique
newUnique = liftF $ NewUnique id
newUniqueHash :: PandocAction Int
newUniqueHash = liftF $ NewUniqueHash id
newUUID :: PandocAction a UUID
newUUID :: PandocAction UUID
newUUID = liftF $ NewUUID id
readFileStrict :: FilePath -> PandocAction a B.ByteString
readFileStrict :: FilePath -> PandocAction B.ByteString
readFileStrict fp = liftF $ ReadFileStrict fp id
readFileLazy :: FilePath -> PandocAction a BL.ByteString
readFileLazy :: FilePath -> PandocAction BL.ByteString
readFileLazy fp = liftF $ ReadFileLazy fp id
readFileUTF8 :: FilePath -> PandocAction a String
readFileUTF8 :: FilePath -> PandocAction String
readFileUTF8 fp = liftF $ ReadFileUTF8 fp id
readDataFile :: Maybe FilePath -> FilePath -> PandocAction a B.ByteString
readDataFile :: Maybe FilePath -> FilePath -> PandocAction B.ByteString
readDataFile mfp fp = liftF $ ReadDataFile mfp fp id
fetchItem :: Maybe String ->
String ->
PandocAction a (Either E.SomeException (B.ByteString, Maybe MimeType))
PandocAction (Either E.SomeException (B.ByteString, Maybe MimeType))
fetchItem ms s = liftF $ FetchItem ms s id
fetchItem' :: MediaBag ->
Maybe String ->
String ->
PandocAction a (Either E.SomeException (B.ByteString, Maybe MimeType))
PandocAction (Either E.SomeException (B.ByteString, Maybe MimeType))
fetchItem' mb ms s = liftF $ FetchItem' mb ms s id
warn :: String -> PandocAction a ()
warn :: String -> PandocAction ()
warn s = liftF $ Warn s ()
fail :: String -> PandocAction a b
fail :: String -> PandocAction b
fail s = liftF $ Fail s
newIORef :: a -> PandocAction a (IORef a)
newIORef v = liftF $ NewIORef v id
glob :: String -> PandocAction [FilePath]
glob s = liftF $ Glob s id
modifyIORef :: (IORef a) -> (a -> a) -> PandocAction a ()
modifyIORef ref f = liftF $ ModifyIORef ref f ()
readIORef :: (IORef a) -> PandocAction a a
readIORef ref = liftF $ ReadIORef ref id
namesMatching :: String -> PandocAction a [FilePath]
namesMatching s = liftF $ NamesMatching s id
runIO :: PandocAction ref nxt -> IO nxt
runIO :: PandocAction nxt -> IO nxt
runIO (Free (LookupEnv s f)) = IO.lookupEnv s >>= runIO . f
runIO (Free (GetCurrentTime f)) = IO.getCurrentTime >>= runIO . f
runIO (Free (GetPOSIXTime f)) = IO.getPOSIXTime >>= runIO . f
@ -190,7 +179,7 @@ runIO (Free (GetDefaultReferenceDocx mfp f)) =
runIO (Free (GetDefaultReferenceODT mfp f)) =
IO.getDefaultReferenceODT mfp >>= runIO . f
runIO (Free (NewStdGen f)) = IO.newStdGen >>= runIO . f
runIO (Free (NewUnique f)) = IO.newUnique >>= runIO . f
runIO (Free (NewUniqueHash f)) = hashUnique <$> IO.newUnique >>= runIO . f
runIO (Free (NewUUID f)) = IO.getRandomUUID >>= runIO . f
runIO (Free (ReadFileStrict fp f)) = B.readFile fp >>= runIO . f
runIO (Free (ReadFileLazy fp f)) = BL.readFile fp >>= runIO . f
@ -202,8 +191,120 @@ runIO (Free (FetchItem sourceUrl nm f)) =
runIO (Free (FetchItem' media sourceUrl nm f)) =
IO.fetchItem' media sourceUrl nm >>= runIO . f
runIO (Free (Warn s nxt)) = IO.warn s >> runIO nxt
runIO (Free (NewIORef v f)) = IO.newIORef v >>= runIO . f
runIO (Free (ModifyIORef ref f nxt)) = IO.modifyIORef ref f >> runIO nxt
runIO (Free (ReadIORef ref f)) = IO.readIORef ref >>= runIO . f
runIO (Free (NamesMatching s f)) = IO.namesMatching s >>= runIO . f
runIO (Free (Glob s f)) = IO.glob s >>= runIO . f
runIO (Pure r) = return r
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)
instance E.Exception TestException
type Testing = ReaderT TestEnv (State TestState)
runTest :: PandocAction nxt -> Testing nxt
runTest (Free (LookupEnv s f)) = do
env <- asks envEnv
return (lookup s env) >>= runTest . f
runTest (Free (GetCurrentTime f)) =
asks envTime >>= runTest . f
runTest (Free (GetPOSIXTime f)) =
(utcTimeToPOSIXSeconds <$> asks envTime) >>= runTest . f
runTest (Free (GetDefaultReferenceDocx _ f)) =
asks envReferenceDocx >>= runTest . f
runTest (Free (GetDefaultReferenceODT _ f)) =
asks envReferenceODT >>= runTest . f
runTest (Free (NewStdGen f)) = do
g <- gets stStdGen
let (_, nxtGen) = next g
modify $ \st -> st { stStdGen = nxtGen }
return g >>= runTest . f
runTest (Free (NewUniqueHash f)) = do
uniqs <- gets stUniqStore
case uniqs of
u : us -> do
modify $ \st -> st { stUniqStore = us }
return u >>= runTest . f
_ -> M.fail "uniq store ran out of elements"
runTest (Free (NewUUID f)) = do
word8s <- gets stWord8Store
case word8s of
-- note we use f' because f is a param of the function
a:b:c:d:e:f':g:h:i:j:k:l:m:n:o:p:remaining -> do
modify $ \st -> st { stWord8Store = remaining }
return (UUID a b c d e f' g h i j k l m n o p) >>= runTest . f
_ -> M.fail "word8 supply was not infinite"
runTest (Free (ReadFileStrict fp f)) = do
fps <- asks envFiles
case lookup fp fps of
Just bs -> return bs >>= runTest . f
Nothing -> error "openFile: does not exist"
runTest (Free (ReadFileLazy fp f)) = do
fps <- asks envFiles
case lookup fp fps of
Just bs -> return (BL.fromStrict bs) >>= runTest . f
Nothing -> error "openFile: does not exist"
runTest (Free (ReadFileUTF8 fp f)) = do
fps <- asks envFiles
case lookup fp fps of
Just bs -> return (UTF8.toString bs) >>= runTest . f
Nothing -> error "openFile: does not exist"
-- A few different cases of readDataFile to reimplement, for when
-- there is no filepath and it falls through to readDefaultDataFile
runTest (Free (ReadDataFile Nothing "reference.docx" f)) = do
(B.concat . BL.toChunks . fromArchive) <$>
(runTest $ getDefaultReferenceDocx Nothing) >>=
runTest . f
runTest (Free (ReadDataFile Nothing "reference.odt" f)) = do
(B.concat . BL.toChunks . fromArchive) <$>
(runTest $ getDefaultReferenceODT Nothing) >>=
runTest . f
runTest (Free (ReadDataFile Nothing fname f)) = do
let fname' = if fname == "MANUAL.txt" then fname else "data" </> fname
runTest (readFileStrict fname') >>= runTest . f
runTest (Free (ReadDataFile (Just userDir) fname f)) = do
userDirFiles <- asks envUserDataDir
case lookup (userDir </> fname) userDirFiles of
Just bs -> return bs >>= runTest . f
Nothing -> runTest (readDataFile Nothing fname) >>= runTest . f
runTest (Free (Fail s)) = M.fail s
runTest (Free (FetchItem _ fp f)) = do
fps <- asks envFiles
case lookup fp fps of
Just bs -> return (Right (bs, getMimeType fp)) >>= runTest . f
Nothing -> return (Left $ E.toException TestException) >>= runTest . f
runTest (Free (FetchItem' media sourceUrl nm f)) = do
case lookupMedia nm media of
Nothing -> runTest (fetchItem sourceUrl nm) >>= runTest . f
Just (mime, bs) -> return (Right (B.concat $ BL.toChunks bs, Just mime)) >>= runTest . f
runTest (Free (Warn s nxt)) = do
modify $ \st -> st { stWarnings = s : stWarnings st }
runTest nxt
runTest (Free (Glob s f)) = do
fontFiles <- asks envFontFiles
return (filter (match (compile s)) fontFiles) >>= runTest . f
runTest (Pure r) = return r

2
src/Text/Pandoc/UUID.hs
View file

@ -29,7 +29,7 @@ UUID generation using Version 4 (random method) described
in RFC4122. See http://tools.ietf.org/html/rfc4122
-}
module Text.Pandoc.UUID ( UUID, getRandomUUID ) where
module Text.Pandoc.UUID ( UUID(..), getRandomUUID ) where
import Text.Printf ( printf )
import System.Random ( randomIO )

19
src/Text/Pandoc/Writers/Docx.hs
View file

@ -55,7 +55,6 @@ import Text.Pandoc.Readers.Docx.Util (elemName)
import Control.Monad.Reader
import Control.Monad.State
import Skylighting
import Data.Unique (hashUnique, newUnique)
import System.Random (randomR)
import Text.Printf (printf)
import qualified Control.Exception as E
@ -69,8 +68,6 @@ import Data.Char (ord, isSpace, toLower)
import Text.Pandoc.Free (PandocAction, runIO)
import qualified Text.Pandoc.Free as P
type DocxAction = PandocAction ()
data ListMarker = NoMarker
| BulletMarker
| NumberMarker ListNumberStyle ListNumberDelim Int
@ -149,7 +146,7 @@ defaultWriterState = WriterState{
, stDynamicTextProps = []
}
type WS = ReaderT WriterEnv (StateT WriterState (DocxAction))
type WS = ReaderT WriterEnv (StateT WriterState (PandocAction))
mknode :: Node t => String -> [(String,String)] -> t -> Element
mknode s attrs =
@ -227,7 +224,7 @@ writeDocx opts doc = runIO $ writeDocxPure opts doc
-- | Produce an Docx file from a Pandoc document.
writeDocxPure :: WriterOptions -- ^ Writer options
-> Pandoc -- ^ Document to convert
-> DocxAction BL.ByteString
-> PandocAction BL.ByteString
writeDocxPure opts doc@(Pandoc meta _) = do
let datadir = writerUserDataDir opts
let doc' = walk fixDisplayMath $ doc
@ -614,7 +611,7 @@ styleToOpenXml sm style =
$ backgroundColor style )
]
copyChildren :: Archive -> Archive -> String -> Integer -> [String] -> DocxAction Entry
copyChildren :: Archive -> Archive -> String -> Integer -> [String] -> PandocAction Entry
copyChildren refArchive distArchive path timestamp elNames = do
ref <- parseXml refArchive distArchive path
dist <- parseXml distArchive distArchive path
@ -633,7 +630,7 @@ copyChildren refArchive distArchive path timestamp elNames = do
baseListId :: Int
baseListId = 1000
mkNumbering :: [ListMarker] -> DocxAction [Element]
mkNumbering :: [ListMarker] -> PandocAction [Element]
mkNumbering lists = do
elts <- mapM mkAbstractNum (ordNub lists)
return $ elts ++ zipWith mkNum lists [baseListId..(baseListId + length lists - 1)]
@ -649,7 +646,7 @@ mkNum marker numid =
map (\lvl -> mknode "w:lvlOverride" [("w:ilvl",show (lvl :: Int))]
$ mknode "w:startOverride" [("w:val",show start)] ()) [0..6]
mkAbstractNum :: ListMarker -> DocxAction Element
mkAbstractNum :: ListMarker -> PandocAction Element
mkAbstractNum marker = do
gen <- P.newStdGen
let (nsid, _) = randomR (0x10000000 :: Integer, 0xFFFFFFFF :: Integer) gen
@ -794,10 +791,10 @@ rStyleM styleName = do
let sty' = getStyleId styleName $ sCharStyleMap styleMaps
return $ mknode "w:rStyle" [("w:val",sty')] ()
getUniqueId :: DocxAction String
getUniqueId :: PandocAction String
-- the + 20 is to ensure that there are no clashes with the rIds
-- already in word/document.xml.rel
getUniqueId = (show . (+ 20) . hashUnique) <$> P.newUnique
getUniqueId = (show . (+ 20)) <$> P.newUniqueHash
-- | Key for specifying user-defined docx styles.
dynamicStyleKey :: String
@ -1284,7 +1281,7 @@ defaultFootnotes = [ mknode "w:footnote"
[ mknode "w:r" [] $
[ mknode "w:continuationSeparator" [] ()]]]]
parseXml :: Archive -> Archive -> String -> DocxAction Element
parseXml :: Archive -> Archive -> String -> PandocAction Element
parseXml refArchive distArchive relpath =
case findEntryByPath relpath refArchive `mplus`
findEntryByPath relpath distArchive of

8
src/Text/Pandoc/Writers/EPUB.hs
View file

@ -66,8 +66,6 @@ import Text.HTML.TagSoup (Tag(TagOpen), fromAttrib, parseTags)
import Text.Pandoc.Free (PandocAction, runIO)
import qualified Text.Pandoc.Free as P
type EPUBAction = PandocAction [(FilePath, (FilePath, Maybe Entry))]
-- A Chapter includes a list of blocks and maybe a section
-- number offset. Note, some chapters are unnumbered. The section
-- number is different from the index number, which will be used
@ -77,7 +75,7 @@ data Chapter = Chapter (Maybe [Int]) [Block]
data EPUBState = EPUBState { stMediaPaths :: [(FilePath, (FilePath, Maybe Entry))]
}
type E = StateT EPUBState EPUBAction
type E = StateT EPUBState PandocAction
data EPUBMetadata = EPUBMetadata{
epubIdentifier :: [Identifier]
@ -343,7 +341,7 @@ writeEPUB opts doc = runIO $ writeEPUBPure opts doc
writeEPUBPure :: WriterOptions -- ^ Writer options
-> Pandoc -- ^ Document to convert
-> EPUBAction B.ByteString
-> PandocAction B.ByteString
writeEPUBPure opts doc =
let initState = EPUBState { stMediaPaths = []
}
@ -398,7 +396,7 @@ pandocToEPUB opts doc@(Pandoc meta _) = do
picEntries <- (catMaybes . map (snd . snd)) <$> (gets stMediaPaths)
-- handle fonts
let matchingGlob f = do
xs <- lift $ P.namesMatching f
xs <- lift $ P.glob f
when (null xs) $
lift $ P.warn $ f ++ " did not match any font files."
return xs

8
src/Text/Pandoc/Writers/ICML.hs
View file

@ -28,11 +28,9 @@ import Data.Text as Text (breakOnAll, pack)
import Control.Monad.State
import Network.URI (isURI)
import qualified Data.Set as Set
import Text.Pandoc.Free (runIO)
import Text.Pandoc.Free (runIO, PandocAction)
import qualified Text.Pandoc.Free as P
type ICMLAction = P.PandocAction ()
type Style = [String]
type Hyperlink = [(Int, String)]
@ -44,7 +42,7 @@ data WriterState = WriterState{
, maxListDepth :: Int
}
type WS a = StateT WriterState ICMLAction a
type WS a = StateT WriterState PandocAction a
defaultWriterState :: WriterState
defaultWriterState = WriterState{
@ -130,7 +128,7 @@ writeICML :: WriterOptions -> Pandoc -> IO String
writeICML opts doc = runIO $ writeICMLPure opts doc
-- | Convert Pandoc document to string in ICML format.
writeICMLPure :: WriterOptions -> Pandoc -> ICMLAction String
writeICMLPure :: WriterOptions -> Pandoc -> PandocAction String
writeICMLPure opts (Pandoc meta blocks) = do
let colwidth = if writerWrapText opts == WrapAuto
then Just $ writerColumns opts

6
src/Text/Pandoc/Writers/ODT.hs
View file

@ -53,12 +53,10 @@ import System.FilePath ( takeExtension, takeDirectory, (<.>))
import Text.Pandoc.Free ( PandocAction, runIO )
import qualified Text.Pandoc.Free as P
type ODTAction = PandocAction [Entry]
data ODTState = ODTState { stEntries :: [Entry]
}
type O = StateT ODTState ODTAction
type O = StateT ODTState PandocAction
-- | Produce an ODT file from a Pandoc document.
writeODT :: WriterOptions -- ^ Writer options
@ -68,7 +66,7 @@ writeODT opts doc = runIO $ writeODTPure opts doc
writeODTPure :: WriterOptions
-> Pandoc
-> ODTAction B.ByteString
-> PandocAction B.ByteString
writeODTPure opts doc =
let initState = ODTState{ stEntries = []
}