{-# 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) 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 : 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 : 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 = "