1a38107941725211e7c3f051f7a8f5e12199f03acmaeder{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaederDescription : Json utilities
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaederCopyright : (c) Christian Maeder, DFKI GmbH 2014
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaederLicense : GPLv2 or higher, see LICENSE.txt
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaederMaintainer : Christian.Maeder@dfki.de
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaederStability : provisional
9817968fa7795e90de8d9846976c5c341cbaf456cmaederPortability : non-portable
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaederinspired by Yuriy Iskra's json2-types hackage package
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaeder , mkNameJPair
6c5825dc6324f6572cdc407b69afd59942182389mcodescu , mkPriorityJPair
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaeder , rangeToJPair
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaeder , rangedToJson
1a38107941725211e7c3f051f7a8f5e12199f03acmaeder , ToJson (..)
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaederimport Numeric
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaeder = JString String
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaeder | JNumber Rational
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaeder | JBool Bool
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaeder | JArray [Json]
9d8fab17888d947d9757a16e21d4f29de29e648bcmaeder | JObject [JPair]
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaeder deriving (Eq, Ord)
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaedertype JPair = (String, Json)
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaedershowRat :: Rational -> String
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaedershowRat r = if denominator r == 1 then show $ numerator r else
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaeder show (fromRational r :: Double)
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaeder-- use show to quote strings
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaederinstance Show Json where
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaeder show j = case j of
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaeder JString s -> show s
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaeder JNumber r -> showRat r
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaeder JBool b -> map toLower $ show b
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaeder JNull -> "null"
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaeder JArray js -> show js
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaeder JObject m -> '{'
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaeder : intercalate ","
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaeder (map (\ (k, v) -> show k ++ ":" ++ show v) m)
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaederppJson :: Json -> String
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaederppJson = show . pJ False
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaedergetOpBr :: Json -> Maybe Doc
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaedergetOpBr j = case j of
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaeder JArray (j1 : _) -> Just $ lbrack <> fromMaybe empty (getOpBr j1)
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaeder JObject _ -> Just lbrace
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaeder _ -> Nothing
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaederpJ :: Bool -> Json -> Doc
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaederpJ omitOpBr j = case j of
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaeder JArray js@(j1 : _) -> let md = getOpBr j1 in
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaeder cat [ if omitOpBr then empty else lbrack <> fromMaybe empty md
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaeder , sep (pJA (isJust md) js) ]
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaeder JObject m -> sep [ if omitOpBr then empty else lbrace
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaeder , sep . punctuate comma
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaeder $ map (\ (k, v) -> let md = getOpBr v in
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaeder cat [ text (show k) <> colon <+> fromMaybe empty md
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaeder , Doc.space <> pJ (isJust md) v]) m
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaeder _ -> text (show j)
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaederpJA :: Bool -> [Json] -> [Doc]
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaederpJA omitOpBr l = case l of
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaeder j1 : r@(j2 : _) -> let md = getOpBr j2 in
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaeder (pJ omitOpBr j1 <> comma <+> fromMaybe empty md)
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaeder : pJA (isJust md) r
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaeder [j] -> [pJ omitOpBr j <> rbrack]
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaedermkJStr :: String -> Json
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaedermkJStr = JString
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaedermkJPair :: String -> String -> JPair
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaedermkJPair a b = (a, mkJStr b)
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaedermkNameJPair :: String -> JPair
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaedermkNameJPair = mkJPair "name"
6c5825dc6324f6572cdc407b69afd59942182389mcodescumkPriorityJPair :: String -> JPair
6c5825dc6324f6572cdc407b69afd59942182389mcodescumkPriorityJPair = mkJPair "priority"
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaedermkJNum :: Real b => b -> Json
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaedermkJNum = JNumber . toRational
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaedermkJBool :: Bool -> Json
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaedermkJBool = JBool
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaedertoJson :: Pretty a => GlobalAnnos -> a -> Json
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaedertoJson ga a = mkJStr $ showGlobalDoc ga a ""
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaedermkJObj :: [JPair] -> Json
9d8fab17888d947d9757a16e21d4f29de29e648bcmaedermkJObj l = if null l then JNull else JObject l
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaedermkJArr :: [Json] -> Json
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaedermkJArr l = if null l then JNull else JArray l
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaederrangeToJPair :: Range -> [JPair]
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaederrangeToJPair rg = case rangeToList rg of
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaeder ps -> [mkJPair "range" . show $ prettyRange ps]
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaederrangedToJson :: (GetRange a, Pretty a) => String -> GlobalAnnos -> a -> [JPair]
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaederrangedToJson s ga a = (s, toJson ga a) : rangeToJPair (getRangeSpan a)
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaederanToJson :: GlobalAnnos -> Annotation -> Json
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaederanToJson ga = mkJObj . rangedToJson "annotation" ga
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaedertagJson :: String -> Json -> Json
024703c9d1326c23e307c0b0d453ed3358e87fe4cmaedertagJson s j = mkJObj [(s, j)]
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaederpStr :: CharParser st String
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaeder s <- getInput
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaeder case reads s of
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaeder [(s0, s1)] -> setInput s1 >> return s0
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaederpJBool :: CharParser st Json
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaederpJBool = choice
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaeder $ map (\ b -> let j = mkJBool b in string (show j) >> return j)
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaeder [False, True]
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaederpJNull :: CharParser st Json
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaederpJNull = string (show JNull) >> return JNull
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaederpJNumber :: CharParser st Json
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaederpJNumber = do
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaeder s <- getInput
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaeder case readSigned readFloat s of
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaeder [(n, s1)] -> setInput s1 >> return (JNumber n)
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaederpJson :: CharParser st Json
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaederpJson = tok $ choice [fmap mkJStr pStr, pJBool, pJNull, pJNumber, pJArr, pJObj]
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaedertok :: CharParser st a -> CharParser st a
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaedertok p = p << spaces
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaedercTok :: Char -> CharParser st ()
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaedercTok = forget . tok . char
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaedercommaTok :: CharParser st ()
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaedercommaTok = cTok ','
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaederpJArr :: CharParser st Json
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaederpJArr = cTok '[' >> fmap JArray (sepBy1 pJson commaTok) << cTok ']'
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaederpJObj :: CharParser st Json
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaederpJObj = cTok '{' >> fmap JObject (sepBy1 pJPair commaTok) << cTok '}'
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaederpJPair :: CharParser st JPair
eec57f39b2b18a307ec8c8df3017e92c86ccda3dcmaederpJPair = pair (tok pStr << cTok ':') pJson
e02a1dc213e84dc01f81c3aeb02c4f04f0a2f221cmaeder{- | convert to json with special treatment for numbers, booleans, strings
e02a1dc213e84dc01f81c3aeb02c4f04f0a2f221cmaederand other lists. -}
9817968fa7795e90de8d9846976c5c341cbaf456cmaedermyDataToJson :: MyData -> Json
f8a83ef1fe8873c4625fb5b9be97622fba1ff8c9Eugen KuksamyDataToJson md =
f8a83ef1fe8873c4625fb5b9be97622fba1ff8c9Eugen Kuksa recordFieldToObject :: (String, MyData) -> (String, Json)
bf9c546726b9001c3662a12e5d68ea149b99a44aEugen Kuksa recordFieldToObject (fieldName, value) =
4e9a6943fbd220c49b5984b2f26c854de962467fEugen Kuksa (toSnakeCase fieldName, myDataToJson value)
f8a83ef1fe8873c4625fb5b9be97622fba1ff8c9Eugen Kuksa Builtin typ value -> case typ of
f8a83ef1fe8873c4625fb5b9be97622fba1ff8c9Eugen Kuksa "number" -> case readSigned readFloat value of
f8a83ef1fe8873c4625fb5b9be97622fba1ff8c9Eugen Kuksa [(n, "")] -> JNumber n
f8a83ef1fe8873c4625fb5b9be97622fba1ff8c9Eugen Kuksa _ -> JString value
f8a83ef1fe8873c4625fb5b9be97622fba1ff8c9Eugen Kuksa "bool" | value == "True" -> JBool True
f8a83ef1fe8873c4625fb5b9be97622fba1ff8c9Eugen Kuksa | value == "False" -> JBool False
f8a83ef1fe8873c4625fb5b9be97622fba1ff8c9Eugen Kuksa "string" -> JString value
f8a83ef1fe8873c4625fb5b9be97622fba1ff8c9Eugen Kuksa _ -> JString value
f8a83ef1fe8873c4625fb5b9be97622fba1ff8c9Eugen Kuksa ListOrTuple _ mds -> JArray $ map myDataToJson mds
f8a83ef1fe8873c4625fb5b9be97622fba1ff8c9Eugen Kuksa -- Special cases
d35249e8b76e34d3cbb6adf7d89e9111226a49d6Eugen Kuksa Cons c Nothing [] | c `elem` ["Nothing", "Just", "Left", "Right"] ->
f8a83ef1fe8873c4625fb5b9be97622fba1ff8c9Eugen Kuksa error ("myDataToJson: Constructor should not have appeared: " ++ show c)
f8a83ef1fe8873c4625fb5b9be97622fba1ff8c9Eugen Kuksa Cons _ (Just fields) mds ->
d35249e8b76e34d3cbb6adf7d89e9111226a49d6Eugen Kuksa in JObject $ zipWith (curry recordFieldToObject) fields mds
f8a83ef1fe8873c4625fb5b9be97622fba1ff8c9Eugen Kuksa -- Data types
f8a83ef1fe8873c4625fb5b9be97622fba1ff8c9Eugen Kuksa Cons constructor Nothing mds -> case map myDataToJson mds of
f8a83ef1fe8873c4625fb5b9be97622fba1ff8c9Eugen Kuksa [] -> JString constructor
f8a83ef1fe8873c4625fb5b9be97622fba1ff8c9Eugen Kuksa ijs -> JArray ijs
1a38107941725211e7c3f051f7a8f5e12199f03acmaederclass ToJson a where
1a38107941725211e7c3f051f7a8f5e12199f03acmaeder asJson :: a -> Json
1a38107941725211e7c3f051f7a8f5e12199f03acmaederinstance Data a => ToJson a where
f8a83ef1fe8873c4625fb5b9be97622fba1ff8c9Eugen Kuksa asJson = myDataToJson . normalizeMyDataForSerialization . dataToMyData