module Text.RJson (TranslateField,
TranslateFieldD,
translateField,
ToJson,
ToJsonD,
toJson,
exclude,
arrayPrepend,
arrayAppend,
objectExtras,
genericToJson,
enumToJson,
JsonData(..),
FromJson,
FromJsonD,
objectDefaults,
parseJsonString,
parseJsonByteString,
fromJson,
fromJsonString,
fromJsonByteString,
genericFromJson,
enumFromJson,
stripInitialUnderscores,
toJsonString,
firstCharToUpper,
firstCharToLower,
Union(..), Union3, Union4, Union5, Union6,
Union7,Union8,Union9,Union10,
cond)
where
import Data.Generics.SYB.WithClass.Basics
import Data.Generics.SYB.WithClass.Instances
import Data.Generics.SYB.WithClass.Context
import Data.Generics.SYB.WithClass.Derive
import qualified Data.Map as M
import qualified Text.Printf as Printf
import Data.Char
import Data.Ratio
import Data.Array
import Data.Maybe
import Control.Monad.State.Strict
import Control.Monad.Trans
import Control.Monad.Error
import qualified Text.ParserCombinators.Parsec as P
import qualified Data.ByteString.Lazy as B
import System.IO.Unsafe
import qualified Control.Exception as E
import Codec.Text.IConv
import qualified Data.Word as W
data JsonData = JDString String |
JDNumber Double |
JDArray [JsonData] |
JDBool Bool |
JDNull |
JDObject (M.Map String JsonData)
listJoin :: a -> [a] -> [a]
listJoin _ [] = []
listJoin _ l@[x] = l
listJoin k (x:ys) = x : k : (listJoin k ys)
concatJoin :: String -> [String] -> String
concatJoin k l = concat (listJoin k l)
alistToJsonDict :: [(String, String)] -> String
alistToJsonDict l =
"{" ++
concatJoin "," (map (\(k,v) -> (escapeString k) ++ ":" ++ v) l)
++ "}"
escapeMap :: M.Map Char String
escapeMap = M.fromList [
('\\', "\\"), ('"', "\""), ('\'', "'"), ('\n', "n"),
('\r', "r"), ('\f', "f"), ('\t', "t"), ('\b', "\b")]
escape :: Char -> Maybe String
escape c = M.lookup c escapeMap
allowed' c o
| o > 127 = True
| o >= 32 && o < 127 && c /= '"' = True
| True = False
allowed c = allowed' c (ord c)
hexEscape :: Char -> String
hexEscape c = Printf.printf "\\u%04x" (ord c)
escapeString' :: String -> String
escapeString' [] = "\""
escapeString' (c:cs)
| allowed c =
c : (escapeString' cs)
| True =
(maybe (hexEscape c) (\s -> "\\" ++ s) (escape c)) ++
(escapeString' cs)
escapeString s = '"' : escapeString' s
instance Show JsonData where
show (JDString s) = escapeString s
show (JDNumber n)
| (fromIntegral (floor n)) == n = show (floor n)
| True = show n
show (JDBool True) = "true"
show (JDBool False) = "false"
show (JDArray l) = "[" ++ concatJoin "," (map show l) ++ "]"
show JDNull = "null"
show (JDObject o) = alistToJsonDict (map (\(k,v) -> (k, show v)) (M.toList o))
class TranslateField a where
translateField :: a -> String -> String
data TranslateFieldD a = TranslateFieldD { translateFieldD :: a -> String -> String }
translateFieldProxy :: Proxy TranslateFieldD
translateFieldProxy = error "'translateFieldProxy' value should never be evaluated!"
instance (TranslateField t) => Sat (TranslateFieldD t) where
dict = TranslateFieldD { translateFieldD = translateField }
stripInitialUnderscores "" = ""
stripInitialUnderscores ('_':s) = stripInitialUnderscores s
stripInitialUnderscores s = s
instance Typeable a => TranslateField a where
translateField _ x = stripInitialUnderscores x
class TranslateField a => ToJson a where
toJson :: a -> JsonData
lToJson :: [a] -> JsonData
lToJson l = JDArray (map toJson l)
exclude :: a -> String -> Bool
exclude _ _ = False
arrayPrepend :: a -> [JsonData]
arrayPrepend _ = []
arrayAppend :: a -> [JsonData]
arrayAppend _ = []
objectExtras :: a -> [(String, JsonData)]
objectExtras _ = []
data ToJsonD a = ToJsonD { toJsonD :: a -> JsonData,
excludeD :: a -> String -> Bool,
arrayPrependD :: a -> [JsonData],
arrayAppendD :: a -> [JsonData],
objectExtrasD :: a -> [(String, JsonData)],
translateFieldD' :: a -> String -> String }
toJsonProxy :: Proxy ToJsonD
toJsonProxy = error "'toJsonProxy' value should never be evaluated!"
instance ToJson t => Sat (ToJsonD t) where
dict = ToJsonD { toJsonD = toJson,
excludeD = exclude,
arrayPrependD = arrayPrepend,
arrayAppendD = arrayAppend,
objectExtrasD = objectExtras,
translateFieldD' = translateField }
instance ToJson Bool where
toJson b = JDBool b
instance ToJson Int where
toJson i = JDNumber (fromIntegral i)
instance ToJson Integer where
toJson i = JDNumber (fromIntegral i)
instance ToJson Double where
toJson i = JDNumber i
instance (Integral a, TranslateField a, Typeable a) => ToJson (Ratio a) where
toJson i = JDNumber $ (fromIntegral (numerator i)) / (fromIntegral (denominator i))
instance ToJson Char where
lToJson s = JDString s
toJson c = JDString [c]
instance (Typeable a, ToJson a) => ToJson (Maybe a) where
toJson (Just c) = toJson c
toJson Nothing = JDNull
instance (ToJson a, TranslateField a, Data TranslateFieldD (M.Map String a))
=> ToJson (M.Map String a) where
toJson x = JDObject (M.map toJson x)
instance (ToJson a, TranslateField a, Typeable a) => ToJson [a] where
toJson = lToJson
instance (ToJson a, TranslateField a, Typeable a, Typeable i, Ix i) => ToJson (Array i a) where
toJson a = toJson (elems a)
data Union a b = Union a b deriving Show
$(derive[''Union])
type Union3 a b c = (Union (Union a b) c)
type Union4 a b c d = (Union (Union3 a b c) d)
type Union5 a b c d e = (Union (Union4 a b c d) e)
type Union6 a b c d e f = (Union (Union5 a b c d e) f)
type Union7 a b c d e f g = (Union (Union6 a b c d e f) g)
type Union8 a b c d e f g h = (Union (Union7 a b c d e f g) h)
type Union9 a b c d e f g h i = (Union (Union8 a b c d e f g h) i)
type Union10 a b c d e f g h i j = (Union (Union9 a b c d e f g h i) j)
isJDObject (JDObject _) = True
isJDObject _ = False
jdObjectMap (JDObject m) = m
instance (ToJson a, ToJson b, TranslateField a, TranslateField b, Typeable a, Typeable b, Typeable2 Union) => ToJson (Union a b) where
toJson (Union x y) =
let jx = toJson x
jy = toJson y
in
if isJDObject jx && isJDObject jy
then JDObject (M.union (jdObjectMap jx) (jdObjectMap jy))
else error "Bad toJson conversion: Attempt to unify JSON values which aren't both objects"
getFields :: Data ToJsonD a => a -> [String]
getFields = constrFields . (toConstr toJsonProxy)
typename x = dataTypeName (dataTypeOf toJsonProxy x)
genericToJson :: (Data ToJsonD a, ToJson a, TranslateField a) => a -> JsonData
genericToJson x
| isAlgType (dataTypeOf toJsonProxy x) =
case getFields x of
[] ->
case gmapQ toJsonProxy (toJsonD dict) x of
[v] -> v
vs -> JDArray $ (arrayPrependD dict x) ++ vs ++ (arrayAppendD dict x)
fs ->
let
translatedFsToInclude =
map (translateFieldD' dict x) (filter (not . (excludeD dict x)) (getFields x))
in
JDObject $ M.fromList (objectExtrasD dict x ++ (zip translatedFsToInclude (gmapQ toJsonProxy (toJsonD dict) x)))
| True =
error $ "Unable to serialize the primitive type '" ++ typename x ++ "'"
enumToJson :: (Data ToJsonD a, ToJson a, TranslateField a) => (String -> String) -> a -> JsonData
enumToJson transform x
| isAlgType (dataTypeOf toJsonProxy x) = JDString (transform (showConstr (toConstr toJsonProxy x)))
| True = error "Passed non-algebraic type to enumToJson"
instance (Data ToJsonD t, TranslateField t) => ToJson t where
toJson = genericToJson
#define I(x) ToJson x, Typeable x
instance (I(a), I(b)) => ToJson (a, b) where
toJson (a,b) = JDArray [toJson a, toJson b]
instance (I(a), I(b), I(c)) => ToJson (a,b,c) where
toJson (a,b,c) = JDArray [toJson a, toJson b, toJson c]
instance (I(a), I(b), I(c), I(d)) => ToJson (a,b,c,d) where
toJson (a,b,c,d) = JDArray [toJson a, toJson b, toJson c, toJson d]
instance (I(a), I(b), I(c), I(d), I(e)) => ToJson (a,b,c,d,e) where
toJson (a,b,c,d,e) = JDArray [toJson a, toJson b, toJson c, toJson d, toJson e]
instance (I(a), I(b), I(c), I(d), I(e), I(f)) =>
ToJson (a,b,c,d,e,f) where
toJson (a,b,c,d,e,f) = JDArray [toJson a, toJson b, toJson c, toJson d, toJson e,
toJson f]
instance (I(a), I(b), I(c), I(d), I(e), I(f), I(g)) =>
ToJson (a,b,c,d,e,f,g) where
toJson (a,b,c,d,e,f,g) = JDArray [toJson a, toJson b, toJson c, toJson d, toJson e,
toJson f, toJson g]
#undef I
class TranslateField a => FromJson a where
fromJson :: a -> JsonData -> Either String a
lFromJson :: a -> JsonData -> Either String [a]
lFromJson dummy (JDArray l) = mapM (fromJson dummy) l
objectDefaults :: a -> M.Map String JsonData
objectDefaults _ = M.empty
data FromJsonD a = FromJsonD { fromJsonD :: a -> JsonData -> Either String a,
objectDefaultsD :: a -> M.Map String JsonData,
translateFieldD'' :: a -> String -> String }
fromJsonProxy :: Proxy FromJsonD
fromJsonProxy = error "'fromJsonProxy' should never be evaluated!"
instance FromJson t => Sat (FromJsonD t) where
dict = FromJsonD { fromJsonD = fromJson,
objectDefaultsD = objectDefaults,
translateFieldD'' = translateField }
instance FromJson Char where
fromJson _ (JDString [c]) = Right c
fromJson _ _ = Left "Bad fromJson conversion: JSON string not of length 1 to 'Char'"
lFromJson _ (JDString s) = Right s
lFromJson _ _ = Left "Bad fromJson conversion: Non-string to 'String'"
instance (FromJson a, TranslateField a, Typeable a) => FromJson (Maybe a) where
fromJson _ JDNull = Right Nothing
fromJson _ y =
case fromJson undefined y of
Left err -> Left err
Right v -> Right $ Just v
instance (FromJson a, TranslateField a, Typeable a) => FromJson [a] where
fromJson _ x = lFromJson undefined x
instance FromJson Int where
fromJson _ (JDNumber n)
| (fromIntegral (floor n)) == n = Right (floor n)
| True =
Left "Bad fromJson conversion: number does not approximate an integer ('Int')"
fromJson _ _ = Left "Bad fromJson conversion: Non-numeric to 'Int'"
instance FromJson Integer where
fromJson _ (JDNumber n)
| (fromIntegral (floor n)) == n = Right (floor n)
| True =
Left "Bad fromJson conversion: number does not approximate an integer ('Integer')"
fromJson _ _ = Left "Bad fromJson conversion: Non-numeric to 'Integer'"
instance FromJson Double where
fromJson _ (JDNumber d) = Right d
fromJson _ _ = Left "Bad fromJson conversion: Non-numeric to 'Double'"
instance (Typeable a, Integral a) => FromJson (Ratio a) where
fromJson _ (JDNumber i) = Right (fromRational (toRational i))
fromJson _ _ = Left "Bad fromJson conversion: Non-numeric to instance of 'Ratio'"
instance FromJson Bool where
fromJson _ (JDBool b) = Right b
fromJson _ _ = Left "Bad fromJson conversion: Non-boolean to 'Bool'"
instance (FromJson a, FromJson b, Typeable a, Typeable b, TranslateField a, TranslateField b) => FromJson (Union a b) where
fromJson _ o@(JDObject _) =
let r1 = fromJson undefined o
r2 = fromJson undefined o
in
if isRight r1 && isRight r2
then Right $ Union (fromRight r1) (fromRight r2)
else Left "Bad fromJson conversion: error constructing subpart of union (did not serialize to object)"
fromJson _ _ = Left "Bad fromJson conversion: attempt to convert non-object to Union"
tuperror :: Int -> Either String a
tuperror n = Left $ Printf.printf "Bad fromJson conversion: attempt to convert something that was not a list of length %i to a %i-tuple" n n
#define I(x) FromJson x, Typeable x, TranslateField x
instance (I(a), I(b)) => FromJson (a,b) where
fromJson _ (JDArray [x1,x2]) = do
r1 <- fromJson undefined x1
r2 <- fromJson undefined x2
return (r1,r2)
fromJson _ _ = tuperror 2
instance (I(a), I(b), I(c)) => FromJson (a,b,c) where
fromJson _ (JDArray [x1,x2,x3]) = do
r1 <- fromJson undefined x1
r2 <- fromJson undefined x2
r3 <- fromJson undefined x3
return (r1,r2,r3)
fromJson _ _ = tuperror 3
instance (I(a), I(b), I(c), I(d)) => FromJson(a,b,c,d) where
fromJson _ (JDArray [x1,x2,x3,x4]) = do
r1 <- fromJson undefined x1
r2 <- fromJson undefined x2
r3 <- fromJson undefined x3
r4 <- fromJson undefined x4
return (r1,r2,r3,r4)
fromJson _ _ = tuperror 4
instance (I(a), I(b), I(c), I(d), I(e)) => FromJson (a,b,c,d,e) where
fromJson _ (JDArray [x1,x2,x3,x4,x5]) = do
r1 <- fromJson undefined x1
r2 <- fromJson undefined x2
r3 <- fromJson undefined x3
r4 <- fromJson undefined x4
r5 <- fromJson undefined x5
return (r1,r2,r3,r4,r5)
fromJson _ _ = tuperror 5
instance (I(a), I(b), I(c), I(d), I(e), I(f)) =>
FromJson (a,b,c,d,e,f) where
fromJson _ (JDArray [x1,x2,x3,x4,x5,x6]) = do
r1 <- fromJson undefined x1
r2 <- fromJson undefined x2
r3 <- fromJson undefined x3
r4 <- fromJson undefined x4
r5 <- fromJson undefined x5
r6 <- fromJson undefined x6
return (r1,r2,r3,r4,r5,r6)
fromJson _ _ = tuperror 6
instance (I(a), I(b), I(c), I(d), I(e), I(f), I(g)) =>
FromJson (a,b,c,d,e,f,g) where
fromJson _ (JDArray [x1,x2,x3,x4,x5,x6,x7]) = do
r1 <- fromJson undefined x1
r2 <- fromJson undefined x2
r3 <- fromJson undefined x3
r4 <- fromJson undefined x4
r5 <- fromJson undefined x5
r6 <- fromJson undefined x6
r7 <- fromJson undefined x7
return (r1,r2,r3,r4,r5,r6,r7)
fromJson _ _ = tuperror 7
#undef I
elemsOfMap :: Ord k => M.Map k v -> [k] -> Maybe [v]
elemsOfMap _ [] = Just []
elemsOfMap m (x:xs) = do
r <- M.lookup x m
rs <- elemsOfMap m xs
return (r : rs)
type ErrorWithState e s a = ErrorT e (State s) a
m1 :: (Data FromJsonD a) => ErrorWithState String [JsonData] a
m1 = do
jvl <- lift get
(case jvl of
[] -> throwError "Bad fromJson conversion: Not enough elements in JSON array to satisfy constructor"
(jv:jvs) -> do
lift $ put jvs
(case fromJsonD dict (undefined :: a) jv of
Left e -> throwError e
Right x -> return x))
m2 :: (Data FromJsonD a, TranslateField a) => M.Map String JsonData -> (String -> String) -> a -> ErrorWithState String (M.Map String JsonData, [String]) a
m2 defaults transFunc dummy = do
(m, sl) <- lift get
(case sl of
[] -> throwError "Bad fromJson conversion: Not enough fields in JSON object to satisfy constructor"
(f:fs) -> do
lift $ put (m, fs)
let stripped = transFunc f
(case M.lookup stripped m of
Nothing ->
case M.lookup stripped defaults of
Nothing -> throwError $ "Bad fromJson conversion: Required field not present in JSON object: " ++ stripped
Just v ->
case fromJsonD dict dummy v of
Left e -> throwError e
Right x -> return x
Just v ->
case fromJsonD dict dummy v of
Left e -> throwError e
Right x -> return x))
m3 :: (Data FromJsonD a, TranslateField a) => JsonData -> a -> ErrorWithState String Int a
m3 jsondata dummy = do
s <- get
if s > 0
then throwError "Bad fromJson conversion: Expecting JSON object or array; did not attempt automatic boxing because constructor takes more than one argument."
else do
put (s + 1)
case fromJsonD dict dummy jsondata of
Left e -> throwError e
Right x -> return x
genericFromJson :: (Data FromJsonD a, FromJson a, TranslateField a) => a -> JsonData -> Either String a
genericFromJson dummy (JDArray l) =
case datarep (dataTypeOf fromJsonProxy dummy) of
AlgRep ccs@(c:cs) -> evalArrayConstr ccs
where
evalArrayConstr = tryHead err . dropWhile isLeft . map es
es :: (Data FromJsonD a, FromJson a) => Constr -> Either String a
es c = evalState (runErrorT (fromConstrM fromJsonProxy m1 c)) (tryTail l)
tryTail = cond null (const []) tail
tryHead def = cond null (const def) head
err = Left "Bad fromJson conversion: Type with no constructors!"
AlgRep _ -> Left "Bad fromJson conversion: Type with no constructors!"
_ -> Left "Bad fromJson conversion: Non-algebraic datatype given to 'genericFromJson'"
genericFromJson dummy (JDObject m) =
case datarep (dataTypeOf fromJsonProxy dummy) of
AlgRep cs@(_:_) -> evalConstrs dummy m cs
_ -> Left "Bad fromJson conversion: Non-algebraic datatype given to 'genericFromJson'"
genericFromJson dummy jsondata =
case datarep (dataTypeOf fromJsonProxy dummy) of
AlgRep [c] -> evalState (runErrorT (gmapM fromJsonProxy (m3 jsondata) (fromConstr fromJsonProxy c))) 0
AlgRep _ -> Left "Bad fromJson conversion: Expecting JSON object or array; did not attempt automatic boxing because type has more than one constructor."
genericFromJson _ _ = Left "Bad fromJson conversion: Expecting JSON object or array"
evalConstrs :: (Data FromJsonD a, FromJson a) => a -> M.Map String JsonData -> [Constr] -> Either [Char] a
evalConstrs dummy m = tryHead err . dropWhile isLeft . map (evalConstr dummy m)
where
tryHead def = cond null (const def) head
err = Left "Bad fromJson conversion: Type with no constructors!"
evalConstr :: (Data FromJsonD a, FromJson a) => a -> M.Map String JsonData -> Constr -> Either [Char] a
evalConstr dummy m c = case constrFields c of
[] -> Left $ "Bad fromJson conversion: Attempt to convert JDObect to a non-record algebraic type"
fs -> evalState (runErrorT (gmapM fromJsonProxy (m2 (objectDefaultsD dict dummy) (translateFieldD'' dict dummy)) (fromConstr fromJsonProxy c))) (m, fs)
constrNames :: (Data FromJsonD a, Data TranslateFieldD a) => a -> [String]
constrNames x = map showConstr (dataTypeConstrs (dataTypeOf fromJsonProxy x))
enumFromJson :: (Data FromJsonD a, Data TranslateFieldD a) => (String -> String) -> a -> JsonData -> Either String a
enumFromJson transform dummy (JDString s) =
let cname = (transform s) in
if elem cname (constrNames dummy)
then
case fromConstrM fromJsonProxy Nothing (mkConstr (dataTypeOf fromJsonProxy dummy) cname [] Prefix ) of
Nothing -> Left "Error in enumFromJson"
Just x -> Right x
else Left "Constructor name not recognized in enumFromJson"
enumFromJson _ _ _ = Left "Non-string given to enumFromJson"
instance (Data FromJsonD t, TranslateField t) => FromJson t where
fromJson = genericFromJson
getEncoding :: B.ByteString -> EncodingName
getEncoding s
| B.length s < 4 = "UTF-8"
| True =
let bs1 = B.index s 0
bs2 = B.index s 1
bs3 = B.index s 2
bs4 = B.index s 3
in
if bs1 /= 0 && bs2 == 0 && bs3 == 0 && bs4 == 0
then "UTF-32LE"
else if bs1 /= 0 && bs2 == 0 && bs3 /= 0 && bs4 == 0
then "UTF-16LE"
else if bs1 == 0 && bs2 == 0 && bs3 == 0 && bs4 /= 0
then "UTF-32BE"
else if bs1 == 0 && bs2 /= 0 && bs3 == 0 && bs4 /= 0
then "UTF-16BE"
else if bs1 /= 0 && bs2 /= 0 && bs3 /= 0 && bs4 /= 0
then "UTF-8"
else "UTF-8"
toHaskellString :: EncodingName -> B.ByteString -> String
toHaskellString enc source =
stripBOM $ map chr (pairBytes (B.unpack bs))
where
pairBytes :: [W.Word8] -> [Int]
pairBytes [] = []
pairBytes (c:c':cs) = ((fromIntegral c) + (fromIntegral c')*256) : (pairBytes cs)
bs = convertFuzzy Discard enc "UTF-16LE" source
stripBOM :: String -> String
stripBOM ('\0':'\0':'\xFE':'\xFF':cs) = cs
stripBOM ('\xFF':'\xFE':'\0':'\0':cs) = cs
stripBOM ('\xFE':'\xFF':cs) = cs
stripBOM ('\xFF':'\xFE':cs) = cs
stripBOM ('\xEF':'\xBB':'\xBF':cs) = cs
stripBOM cs = cs
(<|>) = (P.<|>)
parseJsonByteString :: B.ByteString -> Either String JsonData
parseJsonByteString bs =
let
decoded = toHaskellString (getEncoding bs) bs
in
case P.runParser (ws >> jsonValue) () "" decoded of
Left e -> Left (show e)
Right x -> Right x
parseJsonString :: String -> Either String JsonData
parseJsonString s =
case P.runParser (ws >> jsonValue) () "" s of
Left e -> Left (show e)
Right x -> Right x
apply f p = do
r <- p
return (f r)
pconcat p1 p2 = do
l1 <- p1
l2 <- p2
return $ l1 ++ l2
listify :: P.Parser x -> P.Parser [x]
listify = apply (:[])
ws = P.many (P.oneOf [' ','\r','\n','\t','\f','\v'])
number :: P.Parser JsonData
number = do
neg <- (P.char '-' >> return True) <|> return False
i <- P.many1 P.digit
point <- P.option Nothing (apply Just (P.char '.' >> P.many1 P.digit))
exponent <- P.option Nothing (apply Just (P.char 'e' >> pconcat (P.option "" (listify (P.char '-'))) (P.many1 P.digit)))
let n = if point == Nothing && exponent == Nothing
then read i :: Double
else read (i ++ (if point == Nothing then "" else "." ++ fromJust point) ++
(if exponent == Nothing then "" else "e" ++ fromJust exponent)) :: Double
return . JDNumber $ if neg then negate n else n
stringChar :: Char -> P.Parser Char
stringChar opener = do
c <- P.satisfy (\c -> c /= opener && (ord c) > 31)
(case c of
'\\' ->
(P.char '"' >> return '"') <|>
(P.char '\'' >> return '\'') <|>
(P.char 'b' >> return '\b') <|>
(P.char 'f' >> return '\f') <|>
(P.char 'n' >> return '\n') <|>
(P.char 'r' >> return '\r') <|>
(P.char 't' >> return '\t') <|>
(do
P.char 'u'
ds <- P.count 4 P.hexDigit
return $ chr (read ("0x" ++ ds) :: Int)) <|>
(P.satisfy allowed >>= return)
c -> return c)
string :: P.Parser String
string = do
opener <- P.char '"' <|> P.char '\''
cs <- P.many (stringChar opener)
P.char opener
return cs
jsonString = apply JDString string
kvp :: P.Parser (String, JsonData)
kvp = do
s <- string
ws
P.char ':'
ws
v <- jsonValue
return (s, v)
lexeme :: P.Parser a -> P.Parser a
lexeme p = do
r <- p
ws
return r
jsonArray :: P.Parser JsonData
jsonArray = do
P.char '['
ws
vs <- P.sepBy (lexeme jsonValue) (P.char ',' >> ws)
ws
P.char ']'
return $ JDArray vs
object :: P.Parser JsonData
object = do
P.char '{'
ws
kvps <- P.sepBy (lexeme kvp) (P.char ',' >> ws)
ws
P.char '}'
return $ JDObject $ M.fromList kvps
boolean :: P.Parser JsonData
boolean = (P.try (P.string "true") >> return (JDBool True)) <|>
(P.string "false" >> return (JDBool False))
jsonNull :: P.Parser JsonData
jsonNull = P.string "null" >> return JDNull
jsonValue = number <|> jsonString <|> jsonArray <|> object <|> boolean <|> jsonNull
fromJsonString :: FromJson a => a -> String -> Either String a
fromJsonString dummy s =
case parseJsonString s of
Left e -> Left (show e)
Right js ->
case fromJson dummy js of
Left e -> Left e
Right js -> Right js
fromJsonByteString :: FromJson a => a -> B.ByteString -> Either String a
fromJsonByteString dummy s =
case parseJsonByteString s of
Left e -> Left (show e)
Right js ->
case fromJson dummy js of
Left e -> Left e
Right js -> Right js
toJsonString :: ToJson a => a -> String
toJsonString = show . toJson
firstCharToUpper :: String -> String
firstCharToUpper "" = ""
firstCharToUpper (c:cs) = (toUpper c) : cs
firstCharToLower :: String -> String
firstCharToLower "" = ""
firstCharToLower (c:cs) = (toLower c) : cs
isLeft :: Either a b -> Bool
isLeft (Left _) = True
isLeft _ = False
isRight :: Either a b -> Bool
isRight (Right _) = True
isRight _ = False
fromLeft :: Either a b -> a
fromLeft (Left x) = x
fromRight :: Either a b -> b
fromRight (Right x) = x
cond :: (a -> Bool) -> (a -> b) -> (a -> b) -> a -> b
cond p th el a = if p a then th a else el a