module Data.Jdh.Json.Generic(
JSValue,
JSProperty,
getInt,
getReal,
getBool,
getStr,
getArray,
getObj,
isNull,
isInt,
isReal,
isBool,
isStr,
isArray,
isObj,
fromNull,
fromInt,
fromReal,
fromBool,
fromStr,
fromArray,
fromProps,
(=:),
stringify,
prettify,
parse,
getProp
) where
import Data.String as S
import Data.Char as C
data JSValue int real str
= JSNull
| JSInt {
getInt :: int
}
| JSReal {
getReal :: real
}
| JSBoolean {
getBool :: Bool
}
| JSString {
getStr :: str
}
| JSArray {
getArray :: [JSValue int real str]
}
| JSObject {
getObj :: [(str, JSValue int real str)]
}
type JSProperty int real str = (str, JSValue int real str)
isNull :: JSValue a b c -> Bool
isNull JSNull = True
isNull _ = False
isInt :: JSValue a b c -> Bool
isInt (JSInt _ ) = True
isInt _ = False
isReal :: JSValue a b c -> Bool
isReal (JSReal _ ) = True
isReal _ = False
isBool :: JSValue a b c -> Bool
isBool (JSBoolean _ ) = True
isBool _ = False
isStr :: JSValue a b c -> Bool
isStr (JSString _ ) = True
isStr _ = False
isArray :: JSValue a b c -> Bool
isArray (JSArray _ ) = True
isArray _ = False
isObj :: JSValue a b c -> Bool
isObj (JSObject _ ) = True
isObj _ = False
fromNull :: (Integral a, Fractional b, S.IsString c) => JSValue a b c
fromNull = JSNull
fromInt :: (Integral a, Fractional b, S.IsString c) => a -> JSValue a b c
fromInt = JSInt
fromReal :: (Integral a, Fractional b, S.IsString c) => b -> JSValue a b c
fromReal = JSReal
fromBool :: (Integral a, Fractional b, S.IsString c) => Bool -> JSValue a b c
fromBool = JSBoolean
fromStr :: (Integral a, Fractional b, S.IsString c) => c -> JSValue a b c
fromStr = JSString
fromArray :: (Integral a, Fractional b, S.IsString c) => [JSValue a b c] -> JSValue a b c
fromArray = JSArray
fromProps :: (Integral a, Fractional b, S.IsString c) => [JSProperty a b c] -> JSValue a b c
fromProps = JSObject
infixl 5 =:
(=:) :: (Integral a, Fractional b, S.IsString c) => c -> JSValue a b c -> JSProperty a b c
propname =: propval = (propname, propval)
tabsize :: String
tabsize = replicate 4 ' '
stringify :: (Integral a, Fractional b, S.IsString c, Show a, Show b, Show c) => JSValue a b c -> String
stringify JSNull = "null"
stringify (JSInt int) = show int
stringify (JSReal real) = show real
stringify (JSBoolean bool) = if bool then "true" else "false"
stringify (JSString str ) = show str
stringify (JSArray arr) = '[' : handle arr where
handle [] = "]"
handle [x] = stringify x ++ "]"
handle (x:xs) = stringify x ++ "," ++ handle xs
stringify (JSObject obj) = '{' : handle obj where
handle [] = "}"
handle [(pname, pval)] = show pname ++ (':': stringify pval) ++ "}"
handle ((pname, pval):xs) = show pname ++ (':': stringify pval) ++ "," ++ handle xs
prettify :: (Integral a, Fractional b, S.IsString c, Show a, Show b, Show c) => JSValue a b c -> String
prettify x = prettify' x False ""
prettify' :: (Integral a, Fractional b, S.IsString c, Show a, Show b, Show c) => JSValue a b c -> Bool -> String -> String
prettify' JSNull False tab = tab ++ "null"
prettify' JSNull True _ = "null"
prettify' (JSInt int) False tab = tab ++ show int
prettify' (JSInt int) True _ = show int
prettify' (JSReal real) False tab = tab ++ show real
prettify' (JSReal real) True _ = show real
prettify' (JSBoolean bool) False tab = tab ++ (if bool then "true" else "false")
prettify' (JSBoolean bool) True _ = if bool then "true" else "false"
prettify' (JSString str ) False tab = tab ++ show str
prettify' (JSString str ) True _ = show str
prettify' (JSArray arr) cameFromObj tab = if not cameFromObj
then tab ++ "[\n" ++ handle arr
else "[\n" ++ handle arr
where
handle [] = tab ++ "]"
handle [x] = prettify' x False (tab++tabsize) ++ "\n" ++ tab ++ "]"
handle (x:xs) = prettify' x False (tab++tabsize) ++ ",\n" ++ handle xs
prettify' (JSObject obj) cameFromObj tab = if not cameFromObj
then tab ++ "{\n" ++ handle obj
else "{\n" ++ handle obj
where
handle [] = tab ++ "}"
handle [(pname, pval)] = tab ++ tabsize ++ show pname ++ ": "
++ prettify' pval True (tab ++ tabsize) ++ "\n" ++ tab ++ "}"
handle ((pname, pval):xs) = tab ++ tabsize ++ show pname ++ ": "
++ prettify' pval True (tab ++ tabsize) ++ ",\n" ++ handle xs
skipWhitespace :: String -> String
skipWhitespace = dropWhile (`elem` " \n\r\t")
parse :: (Integral a, Fractional b, S.IsString c, Read a, Read b, Read c) => String -> [(JSValue a b c, String)]
parse [] = []
parse string
| null skipped = []
| C.isDigit $ head skipped = if '.' `elem` takeWhile (\ x -> C.isDigit x || x == '.') skipped
then
let readtry = reads skipped :: (Fractional b, Read b) => [(b, String)]
in if null readtry
then []
else let [(number, remains)] = readtry in [(JSReal number, remains)]
else
let readtry = reads skipped :: (Integral a, Read a) => [(a, String)]
in if null readtry
then []
else let [(number, remains)] = readtry in [(JSInt number, remains)]
| head skipped == '"' = let readtry = reads skipped in if null readtry
then []
else
let [(str, remains)] = readtry
in [(JSString str, remains)]
| head skipped == 'n' = [(JSNull, drop 4 skipped) | length skipped >= 4 && take 4 skipped == "null"]
| head skipped == 't' = [(JSBoolean True, drop 4 skipped) | length skipped >= 4 && take 4 skipped == "true"]
| head skipped == 'f' = [(JSBoolean False, drop 5 skipped) | length skipped >= 5 && take 5 skipped == "false"]
| head skipped == '[' =
let str = skipWhitespace (drop 1 skipped) in if null str then [] else if head str == ']'
then [(JSArray [], drop 1 str)]
else
let handle [(tillnow, remains)] = if null readRem then [] else
let [(parsed, remains')] = readRem
skippedRem = skipWhitespace remains'
in if null skippedRem then [] else if head skippedRem == ']'
then [(tillnow ++ [parsed], drop 1 skippedRem)]
else if head skippedRem == ','
then handle [(tillnow ++ [parsed], skipWhitespace $ drop 1 skippedRem)]
else []
where
readRem = parse remains
handle _ = []
answer = handle [([], str)]
in if null answer
then []
else
let [(arr, remstr)] = answer
in [(JSArray arr, remstr)]
| head skipped == '{' = let str = skipWhitespace (drop 1 skipped) in if null str then [] else if head str == '}'
then [(JSObject [], drop 1 str)]
else
let handle [(tillnow, remains)] = if null readRemKey then [] else
let [(parsedkey, remainskey)] = readRemKey
skippedRemKey = skipWhitespace remainskey
in if null skippedRemKey || head skippedRemKey /= ':' then [] else
let readRemVal = parse $ skipWhitespace $ drop 1 remainskey
in if null readRemVal then [] else
let [(parsedVal, remainsVal)] = readRemVal
skippedRemVal = skipWhitespace remainsVal
in if null skippedRemVal then [] else if head skippedRemVal == '}'
then [(tillnow ++ [parsedkey =: parsedVal], drop 1 skippedRemVal)]
else if head skippedRemVal == ','
then handle [(tillnow ++ [parsedkey =: parsedVal], skipWhitespace $ drop 1 skippedRemVal)]
else []
where
readRemKey = reads remains
handle _ = []
answer = handle [([], str)]
in if null answer
then []
else
let [(arr, remstr)] = answer
in [(JSObject arr, remstr)]
| otherwise = []
where
skipped = skipWhitespace string
getProp :: (Integral a, Fractional b, S.IsString c, Eq c) => c -> JSValue a b c -> Maybe (JSValue a b c)
getProp property (JSObject ((propname, val):xs)) = if propname == property
then Just val
else getProp property (JSObject xs)
getProp _ _ = Nothing
instance (Integral a, Fractional b, S.IsString c, Show a, Show b, Show c) => Show (JSValue a b c ) where
show = prettify
instance (Integral a, Fractional b, S.IsString c, Read a, Read b, Read c) => Read (JSValue a b c ) where
readsPrec _ = parse
instance (Integral a, Fractional b, S.IsString c, Eq a, Eq b, Eq c) => Eq (JSValue a b c) where
JSNull == JSNull = True
JSNull == _ = False
(JSBoolean a) == (JSBoolean b) = a == b
(JSBoolean _) == _ = False
(JSString a) == (JSString b) = a == b
(JSString _) == _ = False
(JSArray a) == (JSArray b) = a == b
(JSArray _) == _ = False
(JSInt a) == (JSInt b) = a == b
(JSInt _) == _ = False
(JSReal a) == (JSReal b) = a == b
(JSReal _) == _ = False
(JSObject a) == (JSObject b) = a == b
(JSObject _) == _ = False