module Data.Derive.JSON (makeJSON) where
import qualified Language.Haskell as H
import Language.Haskell (
Exp, Pat, Alt, CtorDecl, Decl, FullDataDecl, FieldDecl, BangType, Stmt,
(~=), var, pVar, con, strE, strP, apps, qname, sl,
ctorDeclFields, ctorDeclName, dataDeclCtors)
import Data.Derive.DSL.DSL
import Data.Derive.Internal.Derivation
makeJSON :: Derivation
makeJSON = derivationCustomDSL "JSON" custom $
List [Instance ["JSON"] "JSON" (List [App "InsDecl" (List [App
"FunBind" (List [List [App "Match" (List [App "Ident" (List [
String "readJSON"]),List [App "PParen" (List [App "PApp" (List [
App "UnQual" (List [App "Ident" (List [String "JSObject"])]),List
[App "PVar" (List [App "Ident" (List [String "x"])])]])])],App
"Nothing" (List []),App "UnGuardedRhs" (List [App "SpliceExp" (
List [App "ParenSplice" (List [App "Var" (List [App "UnQual" (List
[App "Ident" (List [String "readJSON"])])])])])]),App "BDecls" (
List [List []])]),App "Match" (List [App "Ident" (List [String
"readJSON"]),List [App "PWildCard" (List [])],App "Nothing" (List
[]),App "UnGuardedRhs" (List [App "App" (List [App "Con" (List [
App "UnQual" (List [App "Ident" (List [String "Error"])])]),App
"Lit" (List [App "String" (List [String "..."])])])]),App "BDecls"
(List [List []])])]])]),App "InsDecl" (List [App "FunBind" (List [
MapCtor (App "Match" (List [App "Ident" (List [String "showJSON"])
,List [App "PParen" (List [App "PApp" (List [App "UnQual" (List [
App "Ident" (List [CtorName])]),MapField (App "PVar" (List [App
"Ident" (List [Concat (List [String "x",ShowInt FieldIndex])])]))]
)])],App "Nothing" (List []),App "UnGuardedRhs" (List [App
"SpliceExp" (List [App "ParenSplice" (List [App "App" (List [App
"Var" (List [App "UnQual" (List [App "Ident" (List [String
"showJSON"])])]),App "Lit" (List [App "Int" (List [CtorIndex])])])
])])]),App "BDecls" (List [List []])]))])])])]
custom :: FullDataDecl -> [Decl] -> [Decl]
custom = customSplice splice
splice :: FullDataDecl -> Exp -> Exp
splice d x | x ~= "readJSON" = mkRead d
splice d (H.App x (H.Lit (H.Int y))) | x~= "showJSON" = mkShow d y
splice _ e = error $ "makeJSON: unrecognized splice: " ++ show e
mkShow :: FullDataDecl -> Integer -> Exp
mkShow d y = let
hasFields = any (not . null . fst) (ctorDeclFields c)
c = dataDeclCtors (snd d) !! fromInteger y
mkFields = if hasFields then mkShowRecordFields else mkShowPlainFields
in
mkJSObject $ H.List
[H.Tuple [strE (ctorDeclName c), mkFields (ctorDeclFields c)]]
mkShowPlainFields :: FieldDecl -> Exp
mkShowPlainFields fs = mkJSArray $ H.List
[var "showJSON" `H.App` xi | xi <- vars "x" fs]
mkShowRecordFields :: FieldDecl -> Exp
mkShowRecordFields fs = mkJSObject $ H.List
[ H.Tuple [strE fn, var "showJSON" `H.App` xi]
| ((fn, _), xi) <- zip fs (vars "x" fs)]
mkRead :: FullDataDecl -> Exp
mkRead (_, d) = let
readError = con "Error" `H.App` strE "malformed JSON for type ...: ..."
in
H.Case (var "fromJSObject" `H.App` var "x") $
map mkReadCtor (dataDeclCtors d) ++
[H.Alt H.sl H.PWildCard (H.UnGuardedAlt readError) (H.BDecls [])]
mkReadCtor :: CtorDecl -> Alt
mkReadCtor c = let
cn = ctorDeclName c
fs = ctorDeclFields c
hasFields = any (not . null . fst) fs
body | hasFields = mkReadRecord cn fs
| otherwise = mkReadPlain cn fs
in
H.Alt sl (H.PList [H.PTuple [strP cn, pVar "y"]])
(H.UnGuardedAlt body) (H.BDecls [])
mkReadRecord :: String -> FieldDecl -> Exp
mkReadRecord cn fs = H.Do $
[H.Generator sl (H.PApp (qname "JSObject") [pVar "z"])
(var "return" `H.App` var "y")] ++
[H.LetStmt $ H.BDecls [H.PatBind sl (pVar "d") Nothing
(H.UnGuardedRhs $ var "fromJSObject" `H.App` var "z")
(H.BDecls [])]] ++
zipWith (mkReadRecordField cn) (pVars "x" fs) fs ++
mkReadTrailer cn fs
mkReadRecordField :: String -> Pat -> (String, BangType) -> Stmt
mkReadRecordField cn xi (fn, _) = H.Generator sl xi $
apps (var "maybe") [
var "fail" `H.App` strE (unwords ["readJSON: missing field", fn,
"while decoding a", cn]),
var "return",
apps (var "lookup") [strE fn, var "d"]]
mkReadPlain :: String -> FieldDecl -> Exp
mkReadPlain cn fs = H.Do $
[H.Generator sl (H.PApp (qname "JSArray") [H.PList (pVars "x" fs)])
(var "return" `H.App` var "y")] ++
mkReadTrailer cn fs
mkReadTrailer :: String -> FieldDecl -> [Stmt]
mkReadTrailer cn fs =
[ H.Generator sl yi (var "readJSON" `H.App` xi)
| (xi, yi) <- zip (vars "x" fs) (pVars "y" fs)] ++
[H.Qualifier $ var "return" `H.App` apps (con cn) (vars "y" fs)]
mkJSObject :: Exp -> Exp
mkJSObject e = con "JSObject" `H.App` (var "toJSObject" `H.App` e)
mkJSArray :: Exp -> Exp
mkJSArray e = con "JSArray" `H.App` e
vars :: String -> FieldDecl -> [Exp]
vars pre fs = [var (pre ++ show i) | i <- [1..length fs]]
pVars :: String -> FieldDecl -> [Pat]
pVars pre fs = [pVar (pre ++ show i) | i <- [1..length fs]]