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
= "<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
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' -> "<sup>" ++ [chr $ readNum x'] ++ "</sup>" ++ 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")]