{-# 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, chr) 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 output = superscript $ case testMode t of "citation" -> unlines' . map (pandocToHTML . renderPandoc_ style) $ cits _ -> pandocBib . map (pandocToHTML . renderPandoc_ style) $ bib return (output == getResult 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' $ getResult 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) getResult :: Test -> String getResult t = if isJust (testCitations t) && testMode t == "citation" then unlines' . map (\(a,b) -> drop (length (show b) + 5) a) . flip zip ([0..] :: [Int]) . lines . testResult $ t else testResult t superscript :: String -> String superscript [] = [] superscript (x:xs) = let a = lookup x (map (first (chr . readNum)) sups) in case a of Nothing -> x : superscript xs Just x' -> "" ++ [chr $ readNum x'] ++ "" ++ superscript xs where sups = [("0x00AA","0x0061"),("0x00B2","0x0032"),("0x00B3","0x0033"),("0x00B9","0x0031") ,("0x00BA","0x006F"),("0x02B0","0x0068"),("0x02B1","0x0266"),("0x02B2","0x006A") ,("0x02B3","0x0072"),("0x02B4","0x0279"),("0x02B5","0x027B"),("0x02B6","0x0281") ,("0x02B7","0x0077"),("0x02B8","0x0079"),("0x02E0","0x0263"),("0x02E1","0x006C") ,("0x02E2","0x0073"),("0x02E3","0x0078"),("0x02E4","0x0295"),("0x1D2C","0x0041") ,("0x1D2D","0x00C6"),("0x1D2E","0x0042"),("0x1D30","0x0044"),("0x1D31","0x0045") ,("0x1D32","0x018E"),("0x1D33","0x0047"),("0x1D34","0x0048"),("0x1D35","0x0049") ,("0x1D36","0x004A"),("0x1D37","0x004B"),("0x1D38","0x004C"),("0x1D39","0x004D") ,("0x1D3A","0x004E"),("0x1D3C","0x004F"),("0x1D3D","0x0222"),("0x1D3E","0x0050") ,("0x1D3F","0x0052"),("0x1D40","0x0054"),("0x1D41","0x0055"),("0x1D42","0x0057") ,("0x1D43","0x0061"),("0x1D44","0x0250"),("0x1D45","0x0251"),("0x1D46","0x1D02") ,("0x1D47","0x0062"),("0x1D48","0x0064"),("0x1D49","0x0065"),("0x1D4A","0x0259") ,("0x1D4B","0x025B"),("0x1D4C","0x025C"),("0x1D4D","0x0067"),("0x1D4F","0x006B") ,("0x1D50","0x006D"),("0x1D51","0x014B"),("0x1D52","0x006F"),("0x1D53","0x0254") ,("0x1D54","0x1D16"),("0x1D55","0x1D17"),("0x1D56","0x0070"),("0x1D57","0x0074") ,("0x1D58","0x0075"),("0x1D59","0x1D1D"),("0x1D5A","0x026F"),("0x1D5B","0x0076") ,("0x1D5C","0x1D25"),("0x1D5D","0x03B2"),("0x1D5E","0x03B3"),("0x1D5F","0x03B4") ,("0x1D60","0x03C6"),("0x1D61","0x03C7"),("0x2070","0x0030"),("0x2071","0x0069") ,("0x2074","0x0034"),("0x2075","0x0035"),("0x2076","0x0036"),("0x2077","0x0037") ,("0x2078","0x0038"),("0x2079","0x0039"),("0x207A","0x002B"),("0x207B","0x2212") ,("0x207C","0x003D"),("0x207D","0x0028"),("0x207E","0x0029"),("0x207F","0x006E") ,("0x3194","0x4E09"),("0x3195","0x56DB"),("0x3196","0x4E0A"),("0x3197","0x4E2D") ,("0x3198","0x4E0B"),("0x3199","0x7532"),("0x319A","0x4E59"),("0x319B","0x4E19") ,("0x319C","0x4E01"),("0x319D","0x5929"),("0x319E","0x5730"),("0x319F","0x4EBA") ,("0x02C0","0x0294"),("0x02C1","0x0295"),("0x06E5","0x0648"),("0x06E6","0x064A")]