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
= "<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 "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)