{-# LANGUAGE PatternGuards #-} ----------------------------------------------------------------------------- -- | -- Module : Text.CSL.Input.Json -- 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.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 -- | Build a datatype from a JSON object. Uses selectFields which -- allows to provied default values for fields not present in the JSON -- object. Useble with non algebraic datatype with record fields. 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 = "
\n" ++ concatMap (\x -> " " ++ "
" ++ x ++ "
\n") s ++ "
" pandocToHTML :: [Inline] -> String pandocToHTML [] = [] pandocToHTML (i:xs) | Str s <- i = (entityToChar $ check 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 | EnDash <- i = "–" ++ pandocToHTML xs | Ellipses <- 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 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)