implementation module JSON import StdEnv import StdGeneric, StdMaybe import Text //------------------------------------------------------------------------------------------- toJSON :: a -> String | JSONEncode{|*|} a toJSON x = join "" (JSONEncode{|*|} x []) /* * Generic JSON printer, using a list of strings as continuation */ generic JSONEncode t :: t [String] -> [String] JSONEncode{|Int|} x c = [toString x:c] JSONEncode{|Real|} x c = [toString x:c] JSONEncode{|Char|} x c = [toString x:c] JSONEncode{|Bool|} True c = ["true":c] JSONEncode{|Bool|} False c = ["false":c] JSONEncode{|String|} x c = ["\"",jsonEscape x,"\"":c] JSONEncode{|UNIT|} (UNIT) c = c JSONEncode{|PAIR|} fx fy (PAIR x y) c = fx x [", " : fy y c] JSONEncode{|EITHER|} fx fy (LEFT x) c = fx x c JSONEncode{|EITHER|} fx fy (RIGHT y) c = fy y c JSONEncode{|OBJECT|} fx (OBJECT x) c = fx x c JSONEncode{|CONS of d|} fx (CONS x) c | length d.gcd_fields <> 0 = ["{": fx x ["}":c]] //Record | d.gcd_arity == 0 = ["\"",d.gcd_name,"\"":c] //Constructor without parameters = ["[\"",d.gcd_name,"\", ": fx x ["]":c]] //Constructor with parameters JSONEncode{|FIELD of d|} fx (FIELD x) c = ["\"", d.gfd_name, "\" : " : fx x c] JSONEncode{|[]|} fx x c = JSONEncodeList fx x c JSONEncode{|(,)|} fx fy (x,y) c = ["[": fx x [",": fy y ["]":c]]] JSONEncode{|{}|} fx x c = JSONEncodeList fx [e \\ e <-: x] c JSONEncode{|{!}|} fx x c = JSONEncodeList fx [e \\ e <-: x] c JSONEncode{|Maybe|} fx (Just x) c = fx x c JSONEncode{|Maybe|} fx (Nothing) c = ["null":c] JSONEncode{|JSON|} (JSON s) c = [s:c] //List generation for lists and arrays JSONEncodeList fx x c = ["[": ( flatten ( intersperse [","] (map (flip fx []) x)) ) ++ ["]": c]] //Escape a string jsonEscape :: String -> String jsonEscape src = copyChars 0 0 reps src (createArray (size src + length reps) '\0') where reps = findChars 0 src //Find the special characters findChars :: Int String -> [(!Int,!Char)] findChars i s | i >= size s = [] | c == '\\' || c == '"' || c == '/' || c == '\b' || c == '\f' || c == '\n' || c == '\r' || c == '\t' = [(i,c): findChars (i + 1) s] = findChars (i + 1) s where c = s.[i] //Build the escaped string from the original and the replacements copyChars :: Int Int [(!Int, !Char)] String *String -> *String copyChars is id [] src dest | is < size src = copyChars (is + 1) (id + 1) [] src {dest & [id] = src.[is]} = dest copyChars is id reps=:[(ir,c):rs] src dest | is == ir = copyChars (is + 1) (id + 2) rs src {dest & [id] = '\\', [id + 1] = rep c} = copyChars (is + 1) (id + 1) reps src {dest & [id] = src.[is]} where rep '\\' = '\\' rep '"' = '"' rep '/' = '/' rep '\b' = 'b' rep '\f' = 'f' rep '\n' = 'n' rep '\r' = 'r' rep '\t' = 't' //Unescape a string unescape :: String -> String unescape s = unescape` s 0 where unescape` s offset | offset >= size s = s | s.[offset] == '\\' | offset + 1 >= size s = s | otherwise = tryReplace s (offset + 1) controlChars | otherwise = unescape` s (offset + 1) tryReplace s offset [] = unescape` s offset tryReplace s offset [(c,r):xs] | s.[offset] == c = s % (0, offset - 2) +++ r +++ unescape (s % (offset + 1, size s)) | otherwise = tryReplace s offset xs controlChars = [('\\',"\\"),('"',"\""),('/',"/"),('b',"\b"),('f',"\f"),('n',"\n"),('t',"\t")] //Intersperse an element on a list intersperse :: a [a] -> [a] intersperse i [] = [] intersperse i [x] = [x] intersperse i [x:xs] = [x,i:intersperse i xs] //------------------------------------------------------------------------------------------- fromJSON :: String -> Maybe a | JSONDecode{|*|} a fromJSON input = fst (JSONDecode{|*|} (removeWhitespace (snd (lex input 0 [])))) removeWhitespace :: [Token] -> [Token] removeWhitespace l = filter (not o isWhitespaceToken) l isWhitespaceToken :: Token -> Bool isWhitespaceToken (TokenWhitespace _) = True isWhitespaceToken _ = False lex :: String Int [Token] -> (Int, [Token]) lex input offset tokens | offset >= size input = (offset, reverse tokens) //Done = lex input newOffset [token:tokens] //Lex another token and recurse where (newOffset, token) = lexAny input offset lexFunctions lexFunctions = [ lexBracketOpen , lexBracketClose , lexBraceOpen , lexBraceClose , lexColon , lexComma , lexNull , lexTrue , lexFalse , lexWhitespace , lexNumber , lexString ] //Try any of the lexers in the list until one succeeds lexAny :: String Int [(String Int -> Maybe (Int, Token))] -> (Int, Token) lexAny input offset [] = (size input, TokenFail) lexAny input offset [f:fs] = case f input offset of (Just result) = result (Nothing) = lexAny input offset fs //Lex token of fixed size lexFixed chars token input offset | input % (offset,offset + (size chars) - 1) == chars = Just (offset + (size chars), token) = Nothing //Single character lex functions lexBracketOpen = lexFixed "[" TokenBracketOpen lexBracketClose = lexFixed "]" TokenBracketClose lexBraceOpen = lexFixed "{" TokenBraceOpen lexBraceClose = lexFixed "}" TokenBraceClose lexColon = lexFixed ":" TokenColon lexComma = lexFixed "," TokenComma //Fixed width lex functions lexNull = lexFixed "null" TokenNull lexTrue = lexFixed "true" (TokenBool True) lexFalse = lexFixed "false" (TokenBool False) //Variable width lex functions //Whitespace lexWhitespace input offset | last == offset = Nothing = Just (last, TokenWhitespace (input % (offset,last - 1))) where last = findEnd isSpace input offset //Numbers lexNumber input offset | intpart == offset = Nothing | otherwise | fracpart == intpart = Just (intpart, TokenInt (toInt (input % (offset,intpart - 1)))) | otherwise | exppart == fracpart = Just (fracpart, TokenReal (toReal (input % (offset, fracpart - 1)))) | otherwise = Just (exppart, TokenReal (toReal (input % (offset, exppart - 1)))) where intpart = findEnd isDigit input (optMin input offset) fracpart = optFrac input intpart exppart = optExp input fracpart //If the current char is a -, advance the offset by one optMin input offset | offset >= size input = offset | input.[offset] == '-' = offset + 1 = offset //If the current char is a '.' advance the offset as long as we find digits optFrac input offset | offset >= size input = offset | input.[offset] == '.' = findEnd isDigit input (offset + 1) = offset //If the current char is 'e' or 'E' advance the offset as long as we can //after an optional '-'. If we can't advance after the 'e' stop. optExp input offset | offset >= size input = offset | input.[offset] == 'e' || input.[offset] == 'E' | end == offset + 1 = offset | otherwise = end | otherwise = offset where end = findEnd isDigit input (optMin input (offset + 1)) //Find the first offset where the predicate no longer holds findEnd pred input offset | offset >= size input = offset | pred input.[offset] = findEnd pred input (offset + 1) = offset //String lexString input offset | offset >= size input = Nothing | input.[offset] <> '"' = Nothing = Just (end, TokenString (input % (offset + 1, end - 2))) where end = findStringEnd input (offset + 1) findStringEnd input offset | offset >= size input = offset | input.[offset] == '"' = offset + 1 | input.[offset] == '\\' = findStringEnd input (offset + 2) //Skip the escaped character = findStringEnd input (offset + 1) //TODO: Deal with escaped characters /* * Generic JSON parser, using a list of tokens */ generic JSONDecode t :: [Token] -> (Maybe t, [Token]) JSONDecode{|Int|} [TokenInt i:xs] = (Just i, xs) JSONDecode{|Int|} l = (Nothing, l) JSONDecode{|Real|} [TokenReal r:xs] = (Just r, xs) JSONDecode{|Real|} [TokenInt i:xs] = (Just (toReal i), xs) JSONDecode{|Real|} l = (Nothing, l) JSONDecode{|Char|} l =: [TokenString s:xs] | size s == 1 = (Just s.[0],xs) = (Nothing, l) JSONDecode{|Char|} l = (Nothing, l) JSONDecode{|Bool|} [TokenBool b:xs] = (Just b,xs) JSONDecode{|Bool|} l = (Nothing, l) JSONDecode{|String|} [TokenString s:xs] = (Just (unescape s), xs) JSONDecode{|String|} l = (Nothing, l) JSONDecode{|UNIT|} l = (Just UNIT, l) JSONDecode{|PAIR|} fx fy l = case fx l of (Just x,[TokenComma :xs]) = case fy xs of (Just y, ys) = (Just (PAIR x y), ys) _ = (Nothing, l) _ = (Nothing, l) JSONDecode{|EITHER|} fx fy l = case fx l of (Just x, xs) = (Just (LEFT x),xs) (Nothing, xs) = case fy l of (Just y, ys) = (Just (RIGHT y),ys) (Nothing, ys) = (Nothing, l) JSONDecode{|OBJECT|} fx l = case fx l of (Just x, xs) = (Just (OBJECT x),xs) _ = (Nothing, l) JSONDecode{|CONS of d|} fx l | length d.gcd_fields <> 0 = case l of [TokenBraceOpen: xs] = case fx xs of (Just x, [TokenBraceClose :ys]) = (Just (CONS x),ys) _ = (Nothing, l) _ = (Nothing, l) | d.gcd_arity == 0 = case l of [TokenString name: xs] | name == d.gcd_name = case fx xs of (Just x, ys) = (Just (CONS x),ys) _ = (Nothing, l) | otherwise = (Nothing, l) _ = (Nothing, l) | otherwise = case l of [TokenBracketOpen, TokenString name, TokenComma:xs] | name == d.gcd_name = case fx xs of (Just x, [TokenBracketClose:ys]) = (Just (CONS x),ys) _ = (Nothing, l) | otherwise = (Nothing, l) _ = (Nothing, l) JSONDecode{|CONS|} fx l = (Nothing, l) JSONDecode{|FIELD of d|} fx l =: [TokenString name, TokenColon : value] | d.gfd_name == name = case fx value of (Just x, xs) = (Just (FIELD x),xs) (Nothing,_) = (Nothing, l) | otherwise = (Nothing, l) JSONDecode{|FIELD|} fx l = (Nothing, l) JSONDecode{|[]|} fx l = case l of [TokenBracketOpen,TokenBracketClose: xs] = (Just [], xs) [TokenBracketOpen: xs] = case decodeItems fx xs of (Just items, ys) = (Just items, ys) _ = (Nothing, l) _ = (Nothing, l) JSONDecode{|(,)|} fx fy l = case l of [TokenBracketOpen:xs] = case fx xs of (Just x, [TokenComma:ys]) = case fy ys of (Just y, [TokenBracketClose: zs]) = (Just (x,y), zs) _ = (Nothing, l) _ = (Nothing, l) _ = (Nothing, l) JSONDecode{|{}|} fx l = case l of [TokenBracketOpen,TokenBracketClose: xs] = (Just {}, xs) [TokenBracketOpen: xs] = case decodeItems fx xs of (Just items, ys) = (Just {e \\ e <- items}, ys) _ = (Nothing, l) _ = (Nothing, l) JSONDecode{|{!}|} fx l = case l of [TokenBracketOpen,TokenBracketClose: xs] = (Just {}, xs) [TokenBracketOpen: xs] = case decodeItems fx xs of (Just items, ys) = (Just {e \\ e <- items}, ys) _ = (Nothing, l) _ = (Nothing, l) decodeItems fx l = case fx l of (Just x,[TokenComma:l`]) = case decodeItems fx l` of (Just xs, l``) = (Just [x:xs], l``) _ = (Nothing, l) (Just x,[TokenBracketClose:xs]) = (Just [x], xs) _ = (Nothing, l) JSONDecode{|Maybe|} fx [TokenNull:xs] = (Just Nothing, xs) JSONDecode{|Maybe|} fx l = case fx l of (Just x,xs) = (Just (Just x), xs) _ = (Nothing,l)