module Text.CSL.Input.Json where
import Control.Arrow
import Control.Monad.State
import Data.Generics
import Data.Char (toLower, toUpper)
import Data.List
import qualified Data.Map as M
import Data.Ratio
import Text.JSON.Generic
import Text.JSON.String ( runGetJSON, readJSTopType )
import Text.CSL.Reference
import Text.CSL.Style
readJsonInput :: FilePath -> IO [Reference]
readJsonInput f = readJsonInputString `fmap` readFile f
readJsonInputString :: String -> [Reference]
readJsonInputString s
= let jrefs = procJSObject editJsonInput $ readJsonString s
refs r = case readJSData r of
Ok ref -> ref
Error er -> error ("readJSData: " ++ er)
in case jrefs of
JSObject o -> map (refs . snd) $ fromJSObject o
JSArray ar -> map (refs ) $ ar
_ -> error $ "citeproc: error in reading the Json bibliographic data."
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
readJsonAbbrevFile :: FilePath -> IO [Abbrev]
readJsonAbbrevFile f = readJsonAbbrev `fmap` readJsonFile f
readJsonAbbrev :: JSValue -> [Abbrev]
readJsonAbbrev
= mapSndObj (mapSndObj (M.fromList . mapSndObj fromJString))
where
mapSndObj f = map (second f) . fromObj
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)
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)
| "shortTitle" <- s = ("titleShort" , j)
| isRefDate s
, JSObject js <- j = (camel s , JSArray (editDate $ fromJSObject js))
| "family" <- s = ("familyName" , j)
| "suffix" <- s = ("nameSuffix" , j)
| "URL" <- s = ("url" , 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 []]
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 _ = []
fromJString :: JSValue -> String
fromJString j
| JSString x <- j = fromJSString x
| otherwise = []
defaultJson :: [(String, JSValue)]
defaultJson = fromObj (toJSON emptyReference) ++ fromObj emptyRefDate ++
fromObj emptyPerson ++ fromObj emptyCite'
where
emptyRefDate = toJSON $ RefDate [] [] [] [] [] []
emptyPerson = toJSON $ Agent [] [] [] [] [] [] False
emptyCite' = toJSON $ emptyCite