{-# LANGUAGE PatternGuards, CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Text.CSL.Test -- Copyright : (c) Andrea Rossato -- License : BSD-style (see LICENSE) -- -- Maintainer : Andrea Rossato -- Stability : unstable -- Portability : unportable -- -- A module for reading Frank's citeproc-js testsuite. -- ----------------------------------------------------------------------------- module Text.CSL.Test ( toTest , runTS , test, test',test_ , runTest , Test (..) ) where import Control.Arrow import Control.Monad.State import Data.Char (toLower) import Data.List import Data.Maybe (isJust) import Data.Time import System.Directory import System.Locale import Text.ParserCombinators.Parsec import Text.JSON.Generic import Text.CSL.Input.Json import Text.CSL.Output.Pandoc import Text.CSL.Output.Plain import Text.CSL.Reference import Text.CSL.Pickle ( readXmlString ) import Text.CSL.Parser ( xpStyle, xpLocale, langBase ) import Text.CSL.Proc import Text.CSL.Style import Text.Pandoc.Definition #ifdef EMBED_DATA_FILES import qualified Data.ByteString.UTF8 as BS ( toString ) import Text.CSL.Parser ( localeFiles ) #else import System.IO.Unsafe import Data.IORef import Paths_citeproc_hs ( getDataFileName ) import Text.CSL.Parser ( readLocaleFile ) import Text.CSL.Pickle ( readXmlFile ) #endif data Test = Test { testMode :: String , testInput :: [Reference] , testCSL :: Style , testAbbrevs :: [Abbrev] , testResult :: String , testBibSect :: BibOpts , testCitItems :: Maybe Citations , testCitations :: Maybe Citations } deriving ( Show ) toTest :: JSValue -> Test toTest ob = Test mode input style abbrevs result bibsection cites cites' where getObj f = case procJSObject f ob of JSObject o -> fromJSObject o _ -> error "error #217" object = getObj id objectI = getObj editJsonInput objectC = getObj editJsonCiteItems look s = case lookup s object of Just (JSString x) -> fromJSString x _ -> error $ "in test " ++ s ++ " section." style = readXmlString xpStyle $ look "csl" mode = look "mode" result = look "result" abbrevs = case lookup "abbreviations" object of Just o -> readJsonAbbrev o _ -> [] bibsection = case lookup "bibsection" objectI of Just (JSObject o) -> getBibOpts $ fromJSObject o _ -> Select [] [] cites = case lookup "citation_items" objectC of Just (JSArray cs) -> Just $ map readCite cs _ -> Nothing cites' = case lookup "citations" objectC of Just (JSArray cs) -> Just $ map readJsonCitations cs _ -> Nothing readCite c = case readJSData c of Ok cite -> cite Error er -> error ("citationItems: " ++ er) refs r = case readJSData r of Ok ref -> ref Error er -> error ("readJSData: " ++ er) input = case lookup "input" objectI of Just (JSArray ar) -> map refs ar _ -> error $ "in test input section." getFieldValue o | JSObject os <- o , [("field",JSString f),("value",JSString v)] <- fromJSObject os = (fromJSString f, fromJSString v) | otherwise = error "bibsection: could not parse fields and values" getBibOpts o = let getSec s = case lookup s o of Just (JSArray ar) -> map getFieldValue ar _ -> [] select = getSec "select" include = getSec "include" exclude = getSec "exclude" quash = getSec "quash" in case () of _ | select /= [] -> Select select quash | include /= [] -> Include include quash | exclude /= [] -> Exclude exclude quash | quash /= [] -> Select [] quash | otherwise -> Select [] [] readTestFile :: FilePath -> IO JSValue readTestFile f = do s <- readFile f let fields = ["CSL","RESULT","MODE","INPUT","CITATION-ITEMS","CITATIONS","BIBSECTION","BIBENTRIES", "ABBREVIATIONS"] format = map (toLower . \x -> if x == '-' then '_' else x) return . toJson . zip (map format fields) . map (fieldsParser s) $ fields toJson :: [(String,String)] -> JSValue toJson = JSObject . toJSObject . map getIt where getIt (s,j) | s `elem` ["result","csl","mode"] = (,) s . JSString $ toJSString j | s `elem` ["bibentries"] = (,) s . JSBool $ False | j == [] = (,) s . JSBool $ False | otherwise = (,) s . either error id . resultToEither $ decode j fieldsParser :: String -> String -> String fieldsParser s f = either (const []) id $ parse (fieldParser f) "" s fieldParser :: String -> Parser String fieldParser s = manyTill anyChar (try $ fieldMarkS) >> manyTill anyChar (try $ fieldMarkE) where fieldMarkS = string ">>" >> many (oneOf "= ") >> string s >> many (oneOf "= ") >> string ">>\n" fieldMarkE = string "\n<<" >> many (oneOf "= ") >> string s >> many (oneOf "= ") >> string "<<\n" pandocBib :: [String] -> String pandocBib [] = [] pandocBib s = "
\n" ++ concatMap (\x -> " " ++ "
" ++ x ++ "
\n") s ++ "
" pandocToHTML :: [Inline] -> String pandocToHTML [] = [] pandocToHTML (i:xs) | Str s <- i = (check . entityToChar $ s) ++ pandocToHTML xs | Emph is <- i = "" ++ pandocToHTML is ++ "" ++ pandocToHTML xs | SmallCaps is <- i = "" ++ pandocToHTML is ++ "" ++ pandocToHTML xs | Strong is <- i = "" ++ pandocToHTML is ++ "" ++ pandocToHTML xs | Superscript is <- i = "" ++ pandocToHTML is ++ "" ++ pandocToHTML xs | Subscript is <- i = "" ++ pandocToHTML is ++ "" ++ pandocToHTML xs | Space <- i = " " ++ pandocToHTML xs | Quoted t is <- i = case t of DoubleQuote -> "“" ++ pandocToHTML is ++ "”" ++ pandocToHTML xs SingleQuote -> "‘" ++ pandocToHTML is ++ "’" ++ pandocToHTML xs | Link is x <- i = case snd x of "emph" -> "" ++ pandocToHTML is ++ "" ++ pandocToHTML xs "strong" -> "" ++ pandocToHTML is ++ "" ++ pandocToHTML xs "nodecor" -> "" ++ pandocToHTML is ++ "" ++ pandocToHTML xs "baseline" -> "" ++ pandocToHTML is ++ "" ++ pandocToHTML xs _ -> pandocToHTML is ++ pandocToHTML xs | otherwise = [] where check ('&':[]) = "&" check ('<':ys) = "<" ++ check ys check ('>':ys) = ">" ++ check ys check (y :ys) = y : check ys check [] = [] unlines' :: [String] -> String unlines' [] = [] unlines' (x:[]) = x unlines' (x:xs) = x ++ "\n" ++ unlines' xs #ifndef EMBED_DATA_FILES localeCache :: IORef [(String, Locale)] localeCache = System.IO.Unsafe.unsafePerformIO $ newIORef [] getCachedLocale :: String -> IO [Locale] getCachedLocale n = maybe [] return `fmap` lookup n `fmap` readIORef localeCache putCachedLocale :: String -> Locale -> IO () putCachedLocale n t = modifyIORef localeCache $ \l -> (n, t) : l #endif runTest :: Test -> IO (Bool,String) runTest t = do let locale = case styleDefaultLocale $ testCSL t of x | length x == 2 -> maybe "en-US" id (lookup x langBase) | otherwise -> take 5 x #ifdef EMBED_DATA_FILES ls <- case lookup ("locales-" ++ locale ++ ".xml") localeFiles of Just x' -> return $ readXmlString xpLocale (BS.toString x') _ -> return $ Locale [] [] [] [] [] #else ls' <- getCachedLocale locale ls <- case ls' of [] -> do l <- getDataFileName ("locales/locales-" ++ locale ++ ".xml") b <- doesFileExist l r <- if b then readXmlFile xpLocale l else readLocaleFile $ take 2 locale putCachedLocale locale r return r [x] -> return x _ -> return $ Locale [] [] [] [] [] #endif let opts = procOpts { bibOpts = testBibSect t} style' = testCSL t style = style' {styleLocale = mergeLocales (styleDefaultLocale style') ls $ styleLocale style' ,styleAbbrevs = testAbbrevs t} cites = case (testCitations t, testCitItems t) of (Just cs, _ ) -> cs (_, Just cs) -> cs _ -> [map (\r -> emptyCite { citeId = refId r }) $ testInput t] (BD cits bib) = citeproc opts style (testInput t) cites fixCits = if isJust (testCitations t) then flip (zipWith $ \c n -> ">>[" ++ show n ++ "] " ++ c) ([0..] :: [Int]) else id output = case testMode t of "citation" -> unlines' . fixCits . map (pandocToHTML . renderPandoc_ style) $ cits _ -> pandocBib . map (pandocToHTML . renderPandoc_ style) $ bib return (output == testResult t, output) test :: FilePath -> IO Bool test = doTest readJsonFile 0 test' :: Int -> FilePath -> IO Bool test' = doTest readJsonFile test_ :: Int -> FilePath -> IO Bool test_ = doTest readTestFile doTest :: (FilePath -> IO JSValue) -> Int -> FilePath -> IO Bool doTest rf v f = do when (v >= 2) $ putStrLn f t <- toTest `fmap` rf f (r,o) <- runTest t if r then return () else do let putStrLn' = when (v >= 1) . putStrLn putStrLn $ (tail . takeWhile (/= '.') . dropWhile (/= '_')) f ++ " failed!" putStrLn' "++++++++++++++++++++++++++++++++++++++++++++++++++++++++" putStrLn' $ f ++ " failed!" putStrLn' "Expected:" putStrLn' $ (testResult t) putStrLn' "\nGot:" putStrLn' $ o when (v >= 3) $ putStrLn (show t) putStrLn' "++++++++++++++++++++++++++++++++++++++++++++++++++++++++" return r runTS :: [String] -> Int -> FilePath -> IO () runTS gs v f = do st <- getCurrentTime putStrLn $ (++) (formatTime defaultTimeLocale "%H:%M:%S" st) $ " <--------------START" dc <- sort `fmap` filter (isInfixOf ".json") `fmap` getDirectoryContents f let groupTests = map (head . map fst &&& map snd) . groupBy (\x y -> fst x == fst y) . map (takeWhile (/= '_') &&& tail . dropWhile (/= '_')) runGroups g = do putStrLn "------------------------------------------------------------" putStrLn $ "GROUP \"" ++ fst g ++ "\" has " ++ show (length $ snd g) ++ " tests to run" putStrLn "------------------------------------------------------------" r' <- mapM (test' v . (++) (f ++ fst g ++ "_")) $ snd g return r' filterGroup = if gs /= [] then filter (flip elem gs . fst) else id r <- mapM runGroups $ filterGroup $ groupTests dc putStrLn " ------------------------------------------------------------" putStrLn "| TEST SUMMARY:" putStrLn "------------------------------------------------------------" putStrLn $ "\t" ++ (show $ sum $ map length r) ++ " tests in " ++ (show $ length r) ++ " groups" putStrLn $ "\t" ++ (show $ sum $ map (length . filter id ) r) ++ " successes" putStrLn $ "\t" ++ (show $ sum $ map (length . filter not) r) ++ " failures" et <- getCurrentTime putStrLn $ (++) (formatTime defaultTimeLocale "%H:%M:%S" et) $ " <--------------END" putStrLn $ "Time: " ++ show (diffUTCTime et st)