{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
import qualified Control.Exception as E
import Control.Monad
import Data.Aeson
import Data.Aeson.Types (Parser)
import qualified Data.ByteString.Lazy as BL
import Data.Char (isSpace, toLower)
import Data.List (isInfixOf, sort)
import qualified Data.Map as M
import System.Directory
import System.Environment (getArgs)
import System.Exit
import System.FilePath
import System.IO.Temp (withSystemTempDirectory)
import System.Process
import Text.CSL
import Text.CSL.Compat.Pandoc (writeHtmlString)
import Text.CSL.Reference
import Text.CSL.Style hiding (Number)
import Text.Pandoc (Block (..), Format (..), Inline (..),
Pandoc (..), bottomUp, nullMeta)
import qualified Text.Pandoc.UTF8 as UTF8
import Text.Printf
data TestCase = TestCase{
testMode :: Mode -- mode
, testBibopts :: BibOpts -- bibsection
, testCitations :: [CiteObject] -- citations
, testCitationItems :: Citations -- citation-items
, testCsl :: Style -- csl
, testAbbreviations :: Abbreviations -- abbreviations
, testReferences :: [Reference] -- input
, testResult :: String -- result
} deriving (Show)
data Mode = CitationMode
| CitationRTFMode
| BibliographyMode
| BibliographyHeaderMode
| BibliographyNoSortMode
deriving Show
instance FromJSON Mode where
parseJSON (String "citation") = return CitationMode
parseJSON (String "citation-rtf") = return CitationRTFMode
parseJSON (String "bibliography") = return BibliographyMode
parseJSON (String "bibliography-header") = return BibliographyHeaderMode
parseJSON (String "bibliography-nosort") = return BibliographyNoSortMode
parseJSON _ = fail "Unknown mode"
instance FromJSON TestCase where
parseJSON (Object v) = TestCase <$>
v .: "mode" <*>
v .:? "bibsection" .!= Select [] [] <*>
((v .: "citations") >>= parseCitations) <*>
v .:? "citation_items" .!= [] <*>
(parseCSL <$> (v .: "csl")) <*>
v .:? "abbreviations" .!= (Abbreviations M.empty) <*>
v .: "input" <*>
v .: "result"
where parseCitations :: Data.Aeson.Value -> Parser [CiteObject]
parseCitations x@Array{} = parseJSON x
parseCitations _ = return []
parseJSON _ = fail "Could not parse test case"
newtype CiteObject =
CiteObject { unCiteObject :: [Cite] } deriving Show
instance FromJSON CiteObject where
parseJSON (Array v) =
case fromJSON (Array v) of
Success [Object x, Array _, Array _] ->
CiteObject <$> x .: "citationItems"
Error e -> fail $ "Could not parse CiteObject: " ++ e
x -> fail $ "Could not parse CiteObject" ++ show x
parseJSON x = fail $ "Could not parse CiteObject " ++ show x
#if MIN_VERSION_aeson(0,10,0)
#else
instance FromJSON [CiteObject] where
parseJSON (Array v) = mapM parseJSON $ V.toList v
parseJSON _ = return []
#endif
data TestResult =
Passed
| Skipped
| Failed
| Errored
deriving (Show, Eq)
testDir :: FilePath
testDir = "citeproc-test" </> "processor-tests" </> "machines"
handler :: FilePath -> E.SomeException -> IO TestResult
handler path e = do
putStrLn $ "[ERROR] " ++ path ++ "\n" ++ show e
return Errored
runTest :: FilePath -> IO TestResult
runTest path = E.handle (handler path) $ do
raw <- BL.readFile path
let testCase = either error id $ eitherDecode raw
let procOpts' = ProcOpts (testBibopts testCase) False
style <- localizeCSL Nothing
$ (testCsl testCase) { styleAbbrevs = testAbbreviations testCase }
let refs = testReferences testCase
let cites = map unCiteObject (testCitations testCase) ++ testCitationItems testCase
let cites' = if null cites
then [map (\ref -> emptyCite{ citeId = unLiteral $ refId ref}) refs]
else cites
let expected = adjustEntities $ fixBegins $ trimEnd $ testResult testCase
let mode = testMode testCase
let assemble BibliographyMode xs =
"<div class=\"csl-bib-body\">\n" ++
unlines (map (\x -> " <div class=\"csl-entry\">" ++ x ++
"</div>") xs) ++ "</div>\n"
assemble _ xs = unlines xs
case mode of
BibliographyHeaderMode -> do
putStrLn $ "[SKIPPED] " ++ path ++ "\n"
return Skipped
BibliographyNoSortMode -> do
putStrLn $ "[SKIPPED] " ++ path ++ "\n"
return Skipped
_ -> do
let result = assemble mode
$ map (inlinesToString . renderPandoc style) $
(case mode of {CitationMode -> citations; _ -> bibliography})
$ citeproc procOpts' style refs cites'
if result == expected
then do
putStrLn $ "[PASSED] " ++ path ++ "\n"
return Passed
else do
putStrLn $ "[FAILED] " ++ path
showDiff expected result
putStrLn ""
return Failed
trimEnd :: String -> String
trimEnd = reverse . ('\n':) . dropWhile isSpace . reverse
-- this is designed to mimic the test suite's output:
inlinesToString :: [Inline] -> String
inlinesToString ils =
writeHtmlString
$ bottomUp (concatMap adjustSpans)
$ Pandoc nullMeta [Plain ils]
-- We want & instead of & etc.
adjustEntities :: String -> String
adjustEntities ('&':'#':'3':'8':';':xs) = "&" ++ adjustEntities xs
adjustEntities (x:xs) = x : adjustEntities xs
adjustEntities [] = []
-- citeproc-js test suite expects "citations" to be formatted like
-- .. [0] Smith (2007)
-- >> [1] Jones (2008)
-- To get a meaningful comparison, we remove this.
fixBegins :: String -> String
fixBegins = unlines . map fixLine . lines
where fixLine ('.':'.':'[':xs) = dropWhile isSpace $ dropWhile (not . isSpace) xs
fixLine ('>':'>':'[':xs) = dropWhile isSpace $ dropWhile (not . isSpace) xs
fixLine xs = xs
-- adjust the spans so we fit what the test suite expects.
adjustSpans :: Inline -> [Inline]
adjustSpans (Note [Para xs]) = xs
adjustSpans (Link _ ils _) = ils
adjustSpans (Span ("",[],[]) xs) = xs
adjustSpans (Span ("",["nocase"],[]) xs) = xs
adjustSpans (Span ("",["citeproc-no-output"],[]) _) =
[Str "[CSL STYLE ERROR: reference with no printed form.]"]
adjustSpans (Span (id',classes,kvs) ils) =
[Span (id',classes',kvs') ils]
where classes' = filter (`notElem` ["csl-no-emph","csl-no-strong","csl-no-smallcaps"]) classes
kvs' = if null styles then kvs else (("style", concat styles) : kvs)
styles = ["font-style:normal;" | "csl-no-emph" `elem` classes]
++ ["font-weight:normal;" | "csl-no-strong" `elem` classes]
++ ["font-variant:normal;" | "csl-no-smallcaps" `elem` classes]
adjustSpans (Emph xs) =
RawInline (Format "html") "<i>" : xs ++ [RawInline (Format "html") "</i>"]
adjustSpans (Strong xs) =
RawInline (Format "html") "<b>" : xs ++ [RawInline (Format "html") "</b>"]
adjustSpans (SmallCaps xs) =
RawInline (Format "html") "<span style=\"font-variant:small-caps;\">" : xs ++ [RawInline (Format "html") "</span>"]
adjustSpans x = [x]
showDiff :: String -> String -> IO ()
showDiff expected' result' =
withSystemTempDirectory "test-pandoc-citeproc-XXX" $ \fp -> do
let expectedf = fp </> "expected"
let actualf = fp </> "actual"
UTF8.writeFile expectedf expected'
UTF8.writeFile actualf result'
withDirectory fp $ void $ rawSystem "diff" ["-u","expected","actual"]
withDirectory :: FilePath -> IO a -> IO a
withDirectory fp action = do
oldDir <- getCurrentDirectory
setCurrentDirectory fp
result <- action
setCurrentDirectory oldDir
return result
main :: IO ()
main = do
args <- getArgs
let matchesPattern x
| null args = True
| otherwise = any (`isInfixOf` (map toLower x))
(map (map toLower . takeBaseName) args)
exists <- doesDirectoryExist testDir
unless exists $ do
putStrLn "Downloading test suite"
_ <- rawSystem "git" ["clone", "https://github.com/citation-style-language/test-suite.git", "citeproc-test"]
withDirectory "citeproc-test" $
void $ rawSystem "python" ["processor.py", "--grind"]
testFiles <- if any ('/' `elem`) args
then return args
else (map (testDir </>) . sort .
filter matchesPattern .
filter (\f -> takeExtension f == ".json"))
<$> getDirectoryContents testDir
results <- mapM runTest testFiles
let numpasses = length $ filter (== Passed) results
let numskipped = length $ filter (== Skipped) results
let numfailures = length $ filter (== Failed) results
let numerrors = length $ filter (== Errored) results
putStrLn $ show numpasses ++ " passed; " ++ show numfailures ++
" failed; " ++ show numskipped ++ " skipped; " ++
show numerrors ++ " errored."
let summary = unlines $ zipWith (\fp res -> printf "%-10s %s" (show res) fp) testFiles results
when (null args) $ do -- write log if complete test suite run
ex <- doesFileExist "test-citeproc.log"
when ex $ do
putStrLn "Copying existing test-citeproc.log to test-citeproc.log.old"
copyFile "test-citeproc.log" "test-citeproc.log.old"
putStrLn "Writing test-citeproc.log."
UTF8.writeFile "test-citeproc.log" summary
exitWith $ if numfailures == 0
then ExitSuccess
else ExitFailure $ numfailures + numerrors