citeproc-0.12: test/Spec.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
module Main (main) where
import Citeproc
import Citeproc.CslJson
import Data.Algorithm.DiffContext
import System.TimeIt (timeIt)
import Control.Monad (unless)
import Control.Monad.Trans.State
import Control.Monad.IO.Class (liftIO)
import System.Environment (getArgs)
import System.Exit
import System.Directory (getDirectoryContents, doesFileExist)
import Data.Text (Text)
import qualified Data.Set as Set
import qualified Text.PrettyPrint as Pretty
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Data.List (foldl', isInfixOf, intersperse, sortOn, sort)
import Data.Containers.ListUtils (nubOrdOn)
import Data.Char (isDigit, isLetter, toLower)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as L
import qualified Data.Aeson as A
import Data.Aeson ((.:?), (.!=))
import Data.Text.Encoding (decodeUtf8)
import System.FilePath
import Data.Maybe (fromMaybe, isJust)
import Text.Printf (printf)
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup
#endif

data CiteprocTest a =
  CiteprocTest
  { name          :: Text
  , path          :: FilePath
  , category      :: Text
  , mode          :: Text
  , result        :: Text
  , csl           :: ByteString
  , input         :: [Reference a]
  , bibentries    :: Maybe A.Value
  , bibsection    :: Maybe A.Value
  , citeItems     :: Maybe [Citation a]
  , citations     :: Maybe [Citation a]
  , abbreviations :: Maybe Abbreviations
  , skipReason    :: Maybe Text
  , options       :: Maybe TestOptions
  } deriving (Show)

newtype TestOptions =
    TestOptions { testCiteprocOpts :: CiteprocOptions }
    deriving (Show, Eq)

defaultTestOptions :: TestOptions
defaultTestOptions = TestOptions
    { testCiteprocOpts = defaultCiteprocOptions }

instance A.FromJSON TestOptions where
    parseJSON = A.withObject "TestOptions" $ fmap TestOptions . \v ->
        CiteprocOptions
        <$> v .:? "linkCitations"    .!= False
        <*> v .:? "linkBibliography" .!= False

data TestResult =
    Passed
  | Skipped Text
  | Failed Text Text
  | Errored CiteprocError
  deriving (Show, Eq)

runTest :: CiteprocTest (CslJson Text)
        -> StateT Counts IO TestResult
runTest test = do
  let opts = fromMaybe defaultTestOptions . options $ test
  let cites =
        case citations test of
          Just cs -> cs
          Nothing ->
            case citeItems test of
                Nothing
                  | mode test == "citation"
                    -> [referencesToCitation
                         (nubOrdOn referenceId (input test))]
                  | otherwise
                    -> map (referencesToCitation . (:[]))
                        (nubOrdOn referenceId (input test))
                Just cs -> cs
  let doError err = do
        modify $ \st -> st{ errored = (category test, path test) : errored st }
        liftIO $ do
          TIO.putStrLn $ "[ERRORED]  " <> T.pack (path test)
          TIO.putStrLn $ T.pack $ show err
          TIO.putStrLn ""
        return $ Errored err
  let doSkip reason = do
        modify $ \st -> st{ skipped = (category test, path test) : skipped st }
        liftIO $ do
          TIO.putStrLn $ "[SKIPPED]  " <> T.pack (path test)
          -- TIO.putStrLn $ T.strip reason
          TIO.putStrLn ""
        return $ Skipped reason
  case skipReason test of
    Just reason -> doSkip reason
    Nothing ->
      case parseStyle (const Nothing) (decodeUtf8 $ csl test) of
        Nothing -> doError $ CiteprocParseError
                      "Could not fetch independent parent"
        Just (Left err) -> doError err
        Just (Right style') -> do
            let style = style'{ styleAbbreviations = abbreviations test }
            let loc = mergeLocales Nothing style
            let actual = citeproc (testCiteprocOpts opts)
                           style Nothing (input test) cites
            unless (null (resultWarnings actual)) $ do
              liftIO $ do
                TIO.putStrLn $ "[WARNING]  " <> T.pack (path test)
                mapM_ (TIO.putStrLn . ("==> " <>))
                     $ resultWarnings actual
            case mode test of
              "citation" -> compareTest test
                  (T.intercalate "\n" $ map (renderCslJson' loc)
                                          (resultCitations actual))
              "bibliography" -> compareTest test
                  (T.intercalate "\n"
                    (addDivs $ map (renderCslJson' loc . snd)
                                          (resultBibliography actual)))
              _ -> doSkip $ "unknown mode " <> mode test

renderCslJson' :: Locale -> CslJson Text -> Text
renderCslJson' loc x =
  if T.null res
     then "[CSL STYLE ERROR: reference with no printed form.]"
     else res
 where
  res = renderCslJson True loc x

addDivs :: [Text] -> [Text]
addDivs ts = "<div class=\"csl-bib-body\">" : map addItemDiv ts ++ ["</div>"]
  where addItemDiv t
          | "<div" `T.isPrefixOf` t =
            "  <div class=\"csl-entry\">\n    " <> t <> "\n  </div>"
          | "</div>" `T.isSuffixOf` t =
            "  <div class=\"csl-entry\">" <> t <> "\n  </div>"
          | otherwise =
            "  <div class=\"csl-entry\">" <> t <> "</div>"

referencesToCitation :: [Reference a] -> Citation a
referencesToCitation rs =
  Citation { citationId = Nothing
           , citationNoteNumber = Nothing
           , citationPrefix = Nothing
           , citationSuffix = Nothing
           , citationItems = map (\r ->
               CitationItem{ citationItemId = referenceId r
                           , citationItemLabel = Nothing
                           , citationItemLocator = Nothing
                           , citationItemType = NormalCite
                           , citationItemPrefix = Nothing
                           , citationItemSuffix = Nothing
                           , citationItemData = Nothing }) rs
           }

-- remove >>[0] or ..[1]
removeCitationNums :: Text -> Text
removeCitationNums =
  T.intercalate "\n" . map removeNum . T.lines
 where
  removeNum = T.dropWhile (== ' ') .
              T.dropWhile (\c -> c == '>' || c == '.' ||
                                 c == '[' || c == ']' || isDigit c)


compareTest :: CiteprocTest (CslJson Text)
            -> Text
            -> StateT Counts IO TestResult
compareTest test actual = do
  let expected = if mode test == "citation" && isJust (citations test)
                    then removeCitationNums $ result test
                    else result test
  if actual == expected
     then do
       modify $ \st -> st{ passed = (category test, path test) : passed st }
       -- suppress PASSED messages
       -- liftIO $ TIO.putStrLn $ "[PASSED] " <> path test
       return Passed
     else do
       modify $ \st -> st{ failed = (category test, path test) : failed st }
       liftIO $ do
         TIO.putStrLn $ (if path test `elem` expectedFailures
                            then "[FAILED:EXPECTED] "
                            else "[FAILED:UNEXPECTED] ") <> T.pack (path test)
         showDiff expected actual
       return $ Failed actual expected

splitSections :: ByteString -> [(Text, ByteString)]
splitSections = snd . foldl' go startingState . B.lines . removeBOM
 where
  removeBOM bs = if "\xef\xbb\xbf" `B.isPrefixOf` bs
                    then B.drop 3 bs
                    else bs
  startingState ::
    (Maybe (Text, [ByteString]), [(Text, ByteString)])
  startingState = (Nothing, mempty)
  go (Nothing, accum) t
      | ">>==" `B.isPrefixOf` t =
        let secname = T.toLower $ T.filter (\c -> isLetter c || c == '-')
                      $ decodeUtf8 t
         in (Just (secname, mempty), accum)
      | otherwise   = (Nothing, accum)
  go (Just (sec, buffer), accum) t
      | "<<==" `B.isPrefixOf` t =
        (Nothing, (sec, mconcat $ intersperse "\n" (reverse buffer)) : accum)
      | otherwise               = (Just (sec, t:buffer), accum)


loadTestCase :: FilePath -> IO (CiteprocTest (CslJson Text))
loadTestCase fp = do
  sections <- splitSections <$> B.readFile fp
  let cslBs = fromMaybe mempty $ lookup "csl" sections
  let fromJSON field x =
              case A.eitherDecode (L.fromStrict x) of
                     Left e  -> error $ "JSON decoding error " <>
                                 " in " <> fp <> " (" <>
                                 field <> ")\n" <> show e
                     Right z -> z
  reason <- do
    exists <- doesFileExist (fp <> ".skip")
    if exists
       then Just <$> TIO.readFile (fp <> ".skip")
       else return Nothing
  return CiteprocTest
    { name = T.pack $ dropExtension $ takeBaseName fp
    , path = fp
    , category = T.takeWhile (/='_') $ T.pack $ takeBaseName fp
    , mode = maybe mempty decodeUtf8 $ lookup "mode" sections
    , result = maybe mempty decodeUtf8 $ lookup "result" sections
    , csl = cslBs
    , input = maybe (error "No INPUT") (fromJSON "INPUT") $
               lookup "input" sections
    , bibentries = fromJSON "BIBENTRIES" <$> lookup "bibentries" sections
    , bibsection = fromJSON "BIBSECTION" <$> lookup "bibsection" sections
    , citeItems  = fromJSON "CITATION-ITEMS" <$>
                    lookup "citation-items" sections
    , citations =  removeDuplicates . fromJSON "CITATIONS" <$>
                    lookup "citations" sections
       -- need appropriate fromjson instance:
       -- fromJSON "CITATION" <$> lookup "citation-items" sections
    , abbreviations = fromJSON "ABBREVIATIONS" <$>
                     lookup "abbreviations" sections
    , skipReason = reason
    , options = fromJSON "TESTOPTIONS" <$> lookup "options" sections
    }

-- for motivation see e.g. test/csl/collapse_CitationNumberRangesInsert.txt
-- Later Citations can replace earlier ones with the same citationId.
removeDuplicates :: [Citation a] -> [Citation a]
removeDuplicates [] = []
removeDuplicates (c:cs) =
  case citationId c of
    Just cid ->
      if any (\cit -> citationId cit == Just cid) cs
         then removeDuplicates cs
         else c : removeDuplicates cs
    Nothing -> c : removeDuplicates cs

testDir :: FilePath
testDir = "test" </> "csl"

overrideDir :: FilePath
overrideDir = "test" </> "overrides"

extraDir :: FilePath
extraDir = "test" </> "extra"

main :: IO ()
main = do
  args <- getArgs
  let matchesPattern x =
        takeExtension x == ".txt" &&
        case args of
          [] -> True
          _  -> any (\arg -> map toLower arg `isInfixOf` map toLower x) args
  overrides <- if any ('/' `elem`) args
                  then return []
                  else filter matchesPattern <$>
                          getDirectoryContents overrideDir

  let addDir fp = if fp `elem` overrides
                     then overrideDir </> fp
                     else testDir </> fp

  testFiles <- if any ('/' `elem`) args
                  then return args
                  else do
                    cslTests <- map addDir . filter matchesPattern
                                 <$> getDirectoryContents testDir
                    extraTests <- map (extraDir </>) . filter matchesPattern
                                 <$> getDirectoryContents extraDir
                    return $ cslTests ++ extraTests


  testCases <- sortOn name <$> mapM loadTestCase testFiles
  (_,counts) <- timeIt $
                 runStateT (mapM_ runTest testCases)
                           Counts{ failed   = []
                                 , errored  = []
                                 , passed   = []
                                 , skipped  = [] }
  putStrLn ""
  let categories = sort $ Set.toList
                        $ foldr (Set.insert . category) mempty testCases
  putStrLn $ printf "%-30s %6s %6s %6s %6s"
               ("CATEGORY" :: String)
               ("PASS" :: String)
               ("FAIL" :: String)
               ("ERROR" :: String)
               ("SKIP" :: String)
  let resultsFor cat = do
        let p = length . filter ((== cat) . fst) . passed $ counts
        let f = length . filter ((== cat) . fst) . failed $ counts
        let e = length . filter ((== cat) . fst) . errored $ counts
        let s = length . filter ((== cat) . fst) . skipped $ counts
        let percent = (fromIntegral p / fromIntegral (p + f + e) :: Double)
        putStrLn $ printf "%-30s %6d %6d %6d %6d    |%-20s|"
                     (T.unpack cat) p f e s
                     (replicate (floor (percent * 20.0)) '+')
  mapM_ resultsFor categories
  putStrLn $ printf "%-30s %6s %6s %6s %6s"
               ("-------------" :: String)
               ("-----" :: String)
               ("-----" :: String)
               ("-----" :: String)
               ("-----" :: String)
  putStrLn $ printf "%-30s %6d %6d %6d %6d"
               ("(all)" :: String)
               (length (passed counts))
               (length (failed counts))
               (length (errored counts))
               (length (skipped counts))
  let unexpectedFailures =
        filter ((`notElem` expectedFailures) . snd) (failed counts)
  let unexpectedPasses =
        filter ((`elem` expectedFailures) . snd) (passed counts)
  unless (null unexpectedFailures) $ do
    putStrLn ""
    putStrLn "Unexpected failures"
    putStrLn "-------------------"
    mapM_ (putStrLn . snd) unexpectedFailures
    putStrLn ""
  unless (null unexpectedPasses) $ do
    putStrLn ""
    putStrLn "Unexpected passes"
    putStrLn "-----------------"
    mapM_ (putStrLn . snd) unexpectedPasses
    putStrLn ""
  case length unexpectedFailures + length (errored counts) of
    0 -> do
      putStrLn "(All failures were expected failures.)"
      exitSuccess
    n -> exitWith $ ExitFailure n

data Counts  =
    Counts
    { failed   :: [(Text,FilePath)]  -- category, filepath
    , errored  :: [(Text,FilePath)]
    , passed   :: [(Text,FilePath)]
    , skipped  :: [(Text,FilePath)]
    } deriving (Show)

showDiff :: Text -> Text -> IO ()
showDiff expected actual = do
  -- Use this to see unicode characters (e.g. dashes) better
  -- let f = mconcat . map
  --            (\c -> if isAscii c
  --                      then T.singleton c
  --                      else T.pack (printf "[U+%04X]" (ord c))) . T.unpack
  putStrLn $ Pretty.render $ prettyContextDiff
    (Pretty.text "expected")
    (Pretty.text "actual")
    (Pretty.text . T.unpack . unnumber)
    $ getContextDiff Nothing (T.lines expected) (T.lines actual)

expectedFailures :: [FilePath]
expectedFailures = [
  "test/csl/bugreports_OverwriteCitationItems.txt",
  "test/csl/bugreports_SingleQuoteXml.txt",
  "test/csl/bugreports_SmallCapsEscape.txt",
  "test/csl/bugreports_SortedIeeeItalicsFail.txt",
  "test/csl/bugreports_ikeyOne.txt",
  "test/csl/collapse_AuthorCollapseNoDateSorted.txt",
  "test/csl/date_NegativeDateSort.txt",
  "test/csl/date_NegativeDateSortViaMacro.txt",
  "test/csl/date_NegativeDateSortViaMacroOnYearMonthOnly.txt",
  "test/csl/date_YearSuffixImplicitWithNoDate.txt",
  "test/csl/date_YearSuffixWithNoDate.txt",
  "test/csl/disambiguate_DifferentSpacingInInitials.txt",
  "test/csl/disambiguate_DisambiguationHang.txt",
  "test/csl/disambiguate_IncrementalExtraText.txt",
  "test/csl/disambiguate_InitializeWithButNoDisambiguation.txt",
  "test/csl/disambiguate_PrimaryNameWithNonDroppingParticle.txt",
  "test/csl/disambiguate_PrimaryNameWithParticle.txt",
  "test/csl/disambiguate_YearCollapseWithInstitution.txt",
  "test/csl/disambiguate_YearSuffixAtTwoLevels.txt",
  "test/csl/disambiguate_YearSuffixWithEtAlSubequent.txt",
  "test/csl/disambiguate_YearSuffixWithEtAlSubsequent.txt",
  "test/csl/flipflop_LeadingMarkupWithApostrophe.txt",
  "test/csl/flipflop_OrphanQuote.txt",
  "test/overrides/fullstyles_ABdNT.txt",
  "test/csl/fullstyles_ChicagoAuthorDateSimple.txt",
  "test/csl/integration_FirstReferenceNoteNumberPositionChange.txt",
  "test/csl/integration_IbidOnInsert.txt",
  "test/csl/label_EditorTranslator1.txt",
  "test/csl/magic_CapitalizeFirstOccurringTerm.txt",
  "test/csl/magic_PunctuationInQuoteNested.txt",
  "test/csl/magic_SubsequentAuthorSubstituteNotFooled.txt",
  "test/csl/magic_TermCapitalizationWithPrefix.txt",
  "test/csl/name_CiteGroupDelimiterWithYearSuffixCollapse2.txt",
  "test/csl/name_DelimiterAfterInverted.txt",
  "test/csl/name_EtAlWithCombined.txt",
  "test/csl/name_HebrewAnd.txt",
  "test/csl/name_InTextMarkupInitialize.txt",
  "test/csl/name_InTextMarkupNormalizeInitials.txt",
  "test/csl/number_OrdinalSpacing.txt",
  "test/csl/number_PlainHyphenOrEnDashAlwaysPlural.txt",
  "test/csl/position_FirstTrueOnlyOnce.txt",
  "test/csl/position_IbidInText.txt",
  "test/csl/position_IbidSeparateCiteSameNote.txt",
  "test/csl/position_IbidWithLocator.txt",
  "test/csl/position_IbidWithMultipleSoloCitesInBackref.txt",
  "test/csl/position_IfIbidWithLocatorIsTrueThenIbidIsTrue.txt",
  "test/csl/position_NearNoteSameNote.txt",
  "test/csl/position_ResetNoteNumbers.txt",
  "test/csl/punctuation_FullMontyQuotesIn.txt",
  "test/csl/quotes_QuotesUnderQuotesFalse.txt",
  "test/csl/sort_BibliographyCitationNumberDescending.txt",
  "test/csl/sort_BibliographyCitationNumberDescendingViaCompositeMacro.txt",
  "test/csl/sort_BibliographyCitationNumberDescendingViaMacro.txt",
  "test/csl/sort_ChicagoYearSuffix1.txt",
  "test/csl/sort_ChicagoYearSuffix2.txt",
  "test/csl/sort_LeadingApostropheOnNameParticle.txt",
  "test/csl/sort_OmittedBibRefMixedNumericStyle.txt",
  "test/csl/sort_OmittedBibRefNonNumericStyle.txt",
  "test/csl/sort_RangeUnaffected.txt",
  "test/csl/substitute_SubstituteOnlyOnceTermEmpty.txt",
  "test/csl/bugreports_NoCaseEscape.txt",
  "test/csl/bugreports_LegislationCrash.txt",
  "test/csl/bugreports_EnvAndUrb.txt",
  "test/csl/bugreports_DemoPageFullCiteCruftOnSubsequent.txt",
  "test/csl/bugreports_ChicagoAuthorDateLooping.txt",
  "test/csl/bugreports_AutomaticallyDeleteItemsFails.txt",
  "test/csl/affix_WithCommas.txt",
  "test/csl/affix_CommaAfterQuote.txt",
  "test/overrides/flipflop_NumericField.txt",
  "test/csl/testers_SecondAutoGeneratedZoteroPluginTest.txt",
  "test/csl/testers_FirstAutoGeneratedZoteroPluginTest.txt"
  ]