File: test-citeproc.hs

package info (click to toggle)
haskell-pandoc-citeproc 0.14.3.1-4
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 2,588 kB
  • sloc: xml: 14,814; haskell: 7,752; makefile: 13
file content (252 lines) | stat: -rw-r--r-- 10,230 bytes parent folder | download
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
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE CPP                  #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TypeSynonymInstances #-}

import Prelude
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 &amp; instead of &#38; etc.
adjustEntities :: String -> String
adjustEntities ('&':'#':'3':'8':';':xs) = "&amp;" ++ 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