{-# 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.ByteString.Lazy.UTF8 ( fromString ) 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.Lazy as L import qualified Data.ByteString.UTF8 as U 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 . fromString $ 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 $ L.fromChunks [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)