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
= "<div class=\"csl-bib-body\">\n" ++
concatMap (\x -> " " ++ "<div class=\"csl-entry\">" ++ x ++ "</div>\n") s ++
"</div>"
pandocToHTML :: [Inline] -> String
pandocToHTML [] = []
pandocToHTML (i:xs)
| Str s <- i = (check . entityToChar $ s) ++ pandocToHTML xs
| Emph is <- i = "<i>" ++ pandocToHTML is ++ "</i>" ++ pandocToHTML xs
| SmallCaps is <- i = "<span style=\"font-variant:small-caps;\">" ++ pandocToHTML is ++ "</span>" ++ pandocToHTML xs
| Strong is <- i = "<b>" ++ pandocToHTML is ++ "</b>" ++ pandocToHTML xs
| Superscript is <- i = "<sup>" ++ pandocToHTML is ++ "</sup>" ++ pandocToHTML xs
| Subscript is <- i = "<sub>" ++ pandocToHTML is ++ "</sub>" ++ 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" -> "<span style=\"font-style:normal;\">" ++
pandocToHTML is ++ "</span>" ++ pandocToHTML xs
"strong" -> "<span style=\"font-weight:normal;\">" ++
pandocToHTML is ++ "</span>" ++ pandocToHTML xs
"nodecor" -> "<span style=\"font-variant:normal;\">" ++
pandocToHTML is ++ "</span>" ++ pandocToHTML xs
"baseline" -> "<span style=\"baseline\">" ++
pandocToHTML is ++ "</span>" ++ 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 (error $ x ++ " doesn't seem a valid locale")
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)