A JSON parser and serializer using Zwaluw

json.hs

{-# LANGUAGE TypeOperators, OverloadedStrings, TemplateHaskell #-}

import Web.Zwaluw
import Web.Zwaluw.TH

import Prelude hiding (id, (.))
import Control.Category
import Data.Char
import Data.Foldable (foldMap)


data JSValue
  = JSNull
  | JSBool   Bool
  | JSString String
  | JSNumber Float
  | JSArray  [JSValue]
  | JSObject [(String, JSValue)]
  deriving (Eq, Show)

$(deriveRouters ''JSValue)



jsValue :: Router r (JSValue :- r)
jsValue = ws . (jsNull <> jsBool <> jsString <> jsNumber <> jsArray <> jsObject) . ws

jsNull :: Router r (JSValue :- r)
jsNull = rJSNull . "null" . ws

jsBool :: Router r (JSValue :- r)
jsBool = rJSBool . (rTrue . "true" <> rFalse . "false")

jsString :: Router r (JSValue :- r)
jsString = rJSString . jsString'

jsString' :: Router r (String :- r)
jsString' = "\"" . rList jsChar . "\""

jsChar :: Router r (Char :- r)
jsChar = satisfy (\c -> c /= '"' && c /= '\\')
      <> "\\" . ( foldMap (\(s, c) -> lit [s] . push c) (zip "\"\\/bfnrt" "\"\\/\b\f\n\r\t")
                <> "u" . xmaph chr (Just . ord) (push 0 .~ hex .~ hex .~ hex .~ hex)
                )
  where
    hex :: Router (Int :- r) (Int :- r)
    hex = rDivMod 16 . hexDigit
    rDivMod :: Integral a => a -> Router (a :- a :- r) (a :- r)
    rDivMod i = pure (\(d :- n :- t) -> (n * 16 + d) :- t) (\(a :- t) -> let (n, d) = a `divMod` i in Just (d :- n :- t))

jsNumber :: Router r (JSValue :- r)
jsNumber = rJSNumber . readshow -- still to be made specific

jsArray :: Router r (JSValue :- r)
jsArray = rJSArray . "[" . rListSep jsValue "," . "]"

jsObject :: Router r (JSValue :- r)
jsObject = rJSObject . "{" . rListSep (ws . rPair . jsString' . ws . ":" . jsValue) "," . ws . "}"

ws :: Router r r
ws = manyr " " `printAs` ""