module Text.CSL.Input.Json
( toTest
, runTS
, test, test',test_
, runTest
, Test (..)
, mapJSArray
, readJsonInput
) where
import Control.Arrow
import Control.Monad.State
import Data.Generics
import Data.Char (toLower, toUpper)
import Foreign
import Data.IORef
import Data.List
import Data.Maybe (isJust)
import Data.Ratio
import Data.Time
import System.Directory
import System.Locale
import Text.ParserCombinators.Parsec
import Text.JSON.Generic
import Text.JSON.String ( runGetJSON, readJSTopType )
import Paths_citeproc_hs ( getDataFileName )
import Text.CSL.Output.Pandoc
import Text.CSL.Output.Plain
import Text.CSL.Reference
import Text.CSL.Pickle ( readXmlString
, readXmlFile )
import Text.CSL.Parser ( xpStyle, xpLocale, langBase)
import Text.CSL.Proc
import Text.CSL.Style
import Text.Pandoc.Definition
data Test
= Test
{ testMode :: String
, testInput :: [Reference]
, testCSL :: Style
, testResult :: String
, testBibSect :: BibOpts
, testCitItems :: Maybe Citations
, testCitations :: Maybe Citations
} deriving ( Show )
toTest :: JSValue -> Test
toTest ob = Test mode input style 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"
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 [] []
editJsonCiteItems :: (String, JSValue) -> (String, JSValue)
editJsonCiteItems (s,j)
| "id" <- s = ("citeId" , toString j)
| "label" <- s = ("citeLabel" , toString j)
| "locator" <- s = ("citeLocator" , toString j)
| "note-number" <- s = ("citeNoteNumber", toString j)
| "near-note" <- s = ("nearNote" , toJSBool j)
| "prefix" <- s = ("citePrefix" , affixes j)
| "suffix" <- s = ("citeSuffix" , affixes j)
| "suppress-author" <- s = ("suppressAuthor", toJSBool j)
| "author-only" <- s = ("authorInText" , toJSBool j)
| "author-in-text" <- s = ("authorInText" , toJSBool j)
| otherwise = (s,j)
where
affixes v
| JSString js <- v = JSString . toJSString . show . PlainText . fromJSString $ js
| otherwise = affixes $ toString v
editJsonInput :: (String, JSValue) -> (String, JSValue)
editJsonInput (s,j)
| "dropping-particle" <- s = ("droppingPart" , j)
| "non-dropping-particle" <- s = ("nonDroppingPart", j)
| "comma-suffix" <- s = ("commaSuffix", toJSBool j)
| "id" <- s = ("refId" , toString j)
| isRefDate s
, JSObject js <- j = (s , JSArray (editDate $ fromJSObject js))
| "family" <- s = ("familyName" , j)
| "suffix" <- s = ("nameSuffix" , j)
| "edition" <- s = ("edition" , toString j)
| "volume" <- s = ("volume" , toString j)
| "issue" <- s = ("issue" , toString j)
| "number" <- s = ("number" , toString j)
| "page" <- s = ("page" , toString j)
| "section" <- s = ("section" , toString j)
| "given" <- s
, JSString js <- j = ("givenName" , JSArray . map (JSString . toJSString) . words $ fromJSString js)
| "type" <- s
, JSString js <- j = ("refType" , JSString . toJSString . format . camel $ fromJSString js)
| (c:cs) <- s = (toLower c : camel cs , j)
| otherwise = (s,j)
where
camel x
| '-':y:ys <- x = toUpper y : camel ys
| '_':y:ys <- x = toUpper y : camel ys
| y:ys <- x = y : camel ys
| otherwise = []
format (x:xs) = toUpper x : xs
format [] = []
zipDate x = zip (take (length x) ["year", "month", "day"]) . map toString $ x
editDate x = let seas = case lookup "season" x of
Just o -> [("season",toString o)]
_ -> []
raw = case lookup "raw" x of
Just o -> [("other",o)]
_ -> []
lit = case lookup "literal" x of
Just o -> [("other",o)]
_ -> []
cir = case lookup "circa" x of
Just o -> [("circa",toString o)]
_ -> []
rest = flip (++) (seas ++ lit ++ raw ++ cir)
in case lookup "dateParts" x of
Just (JSArray (JSArray x':[])) -> [JSObject . toJSObject . rest $ zipDate x']
Just (JSArray (JSArray x':
JSArray y':[])) -> [JSObject . toJSObject $ zipDate x'
,JSObject . toJSObject $ zipDate y']
_ -> [JSObject . toJSObject $ rest []]
readJsonCitations :: JSValue -> [Cite]
readJsonCitations jv
| JSArray (JSObject o:_) <- jv
, Just (JSArray ar) <- lookup "citationItems" (fromJSObject o )
, Just (JSObject o') <- lookup "properties" (fromJSObject o )
, idx <- lookup "noteIndex" (fromJSObject o')
= map (readCite $ readCitNum $ fmap toString idx) ar
| otherwise = error ("error in reading CITATIONS:\n" ++ show jv)
where
readCitNum j
| Just (JSString js) <- j = fromJSString js
| otherwise = []
readCite :: String -> JSValue -> Cite
readCite n c = case readJSData c of
Ok cite -> cite { citeNoteNumber = n }
Error er -> error ("citations: " ++ er)
toString :: JSValue -> JSValue
toString x
| JSString js <- x = JSString js
| JSRational _ n <- x = JSString . toJSString . show $ numerator n
| otherwise = JSString . toJSString $ []
toJSBool :: JSValue -> JSValue
toJSBool x
| JSBool b <- x = JSBool b
| JSRational _ n <- x = JSBool (numerator n /= 0)
| JSString js <- x = JSBool (fromJSString js /= [])
| otherwise = JSBool False
procJSObject :: ((String, JSValue) -> (String, JSValue)) -> JSValue -> JSValue
procJSObject f jv
| JSObject o <- jv = JSObject . toJSObject . map f . map (second $ procJSObject f) . fromJSObject $ o
| JSArray ar <- jv = JSArray . map (procJSObject f) $ ar
| otherwise = jv
mapJSArray :: (JSValue -> JSValue) -> JSValue -> JSValue
mapJSArray f jv
| JSArray ar <- jv = JSArray $ map (mapJSArray f) ar
| otherwise = f jv
isRefDate :: String -> Bool
isRefDate = flip elem [ "issued", "event-date", "accessed", "container", "original-date"]
readJSData :: (Data a) => JSValue -> Result a
readJSData j = readType j
`ext1R` jList
`extR` (value :: Result String)
`extR` (value :: Result Affix )
where
value :: (JSON a) => Result a
value = readJSON j
jList :: (Data e) => Result [e]
jList = case j of
JSArray j' -> mapM readJSData j'
_ -> Error $ "fromJSON: Prelude.[] bad data: " ++ show j
readType :: (Data a) => JSValue -> Result a
readType (JSObject ob) = construct
where
construct = selectFields (fromJSObject ob) (constrFields con) >>=
evalStateT (fromConstrM f con) . zip (constrFields con)
resType :: Result a -> a
resType _ = error "resType"
typ = dataTypeOf $ resType construct
con = indexConstr typ 1
f :: (Data a) => StateT [(String,JSValue)] Result a
f = do js <- get
case js of
j':js' -> do put js'
lift $ readJSData (snd j')
[] -> lift $ Error ("construct: empty list")
readType j = fromJSON j
selectFields :: [(String, JSValue)] -> [String] -> Result [JSValue]
selectFields fjs = mapM sel
where sel f = maybe (fb f) Ok $ lookup f fjs
fb f = maybe (Error $ "selectFields: no field " ++ f) Ok $ lookup f defaultJson
fromObj :: JSValue -> [(String, JSValue)]
fromObj (JSObject o) = fromJSObject o
fromObj _ = []
defaultJson :: [(String, JSValue)]
defaultJson = fromObj (toJSON emptyReference) ++ fromObj emptyRefDate ++
fromObj emptyPerson ++ fromObj emptyCite'
where
emptyRefDate = toJSON $ RefDate [] [] [] [] [] []
emptyPerson = toJSON $ Agent [] [] [] [] [] [] False
emptyCite' = toJSON $ emptyCite
readJsonFile :: FilePath -> IO JSValue
readJsonFile f = readJsonString `fmap` readFile f
readJsonString :: String -> JSValue
readJsonString =
let rmCom = unlines . filter (\x -> not (" *" `isPrefixOf` x || "/*" `isPrefixOf` x)) . lines
in either error id . runGetJSON readJSTopType . rmCom
readJsonInput :: FilePath -> IO [Reference]
readJsonInput f = do
js <- readJsonFile f
let jrefs = procJSObject editJsonInput js
refs r = case readJSData r of
Ok ref -> ref
Error er -> error ("readJSData: " ++ er)
case jrefs of
JSObject o -> return . map (refs . snd) $ fromJSObject o
JSArray ar -> return . map (refs ) $ ar
_ -> error $ "citeproc: error in reading the Json bibliographic data."
readTestFile :: FilePath -> IO JSValue
readTestFile f = do
s <- readFile f
let fields = ["CSL","RESULT","MODE","INPUT","CITATION-ITEMS","CITATIONS","BIBSECTION","BIBENTRIES"]
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 = (entityToChar $ check 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
| Quoted _ is <- i = "“" ++ pandocToHTML is ++ "”" ++ pandocToHTML xs
| Space <- i = " " ++ pandocToHTML xs
| EnDash <- i = "–" ++ pandocToHTML xs
| Ellipses <- i = "…" ++ pandocToHTML xs
| Link is x <- i = case snd x of
"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 (y :ys) = y : check ys
check [] = []
unlines' :: [String] -> String
unlines' [] = []
unlines' (x:[]) = x
unlines' (x:xs) = x ++ "\n" ++ unlines' xs
localeCache :: IORef [(String, Locale)]
localeCache = 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
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
ls' <- getCachedLocale locale
ls <- case ls' of
[] -> do l <- getDataFileName ("locales/locales-" ++ locale ++ ".xml")
r <- readXmlFile xpLocale l
putCachedLocale locale r
return r
[x] -> return x
_ -> return $ Locale [] [] [] [] []
let opts = procOpts { bibOpts = testBibSect t}
style' = testCSL t
style = style' {styleLocale = mergeLocales (styleDefaultLocale style') ls $ styleLocale style'}
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)