-- |
-- Copyright:   (c) Bertram Felgenhauer 2009
-- License:     BSD3
-- Stability:   experimental
-- Portability: portable
--
-- Derive 'Text.JSON' instances.
--
-- Unlike Text.JSON.Generics, single constructor types are /not/ handled
-- specially. Every value is encoded as an object with a single field,
-- with the constructor name as key and the values as its contents.
--
-- If the constructor is a record, the contents is an Object with the
-- field names as keys. Otherwise, the contents is an array.

module Data.Derive.JSON (makeJSON) where

import qualified Language.Haskell as H
import Language.Haskell (
    Exp, Pat, Alt, CtorDecl, Decl, FullDataDecl, FieldDecl, Type, Stmt,
    (~=), var, pVar, con, strE, strP, apps, qname,
    ctorDeclFields, ctorDeclName, dataDeclCtors)

{-
import "json" Text.JSON
import Text.JSON.Types

example :: Custom
instance JSON a => JSON (Sample a) where
    readJSON (JSObject x)   = $(readJSON)
    readJSON _              = Error "..."
    showJSON (First)        = $(showJSON 0)
    showJSON (Second x1 x2) = $(showJSON 1)
    showJSON (Third x1)     = $(showJSON 2)
-}

-- GENERATED START

import Data.Derive.DSL.DSL
import Data.Derive.Internal.Derivation

makeJSON :: Derivation
makeJSON = derivationCustomDSL "JSON" custom $
    List [Instance ["JSON"] "JSON" (App "Just" (List [List [App
    "InsDecl" (List [App "()" (List []),App "FunBind" (List [App "()"
    (List []),List [App "Match" (List [App "()" (List []),App "Ident"
    (List [App "()" (List []),String "readJSON"]),List [App "PParen" (
    List [App "()" (List []),App "PApp" (List [App "()" (List []),App
    "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (
    List []),String "JSObject"])]),List [App "PVar" (List [App "()" (
    List []),App "Ident" (List [App "()" (List []),String "x"])])]])])
    ],App "UnGuardedRhs" (List [App "()" (List []),App "SpliceExp" (
    List [App "()" (List []),App "ParenSplice" (List [App "()" (List [
    ]),App "Var" (List [App "()" (List []),App "UnQual" (List [App
    "()" (List []),App "Ident" (List [App "()" (List []),String
    "readJSON"])])])])])]),App "Nothing" (List [])]),App "Match" (List
    [App "()" (List []),App "Ident" (List [App "()" (List []),String
    "readJSON"]),List [App "PWildCard" (List [App "()" (List [])])],
    App "UnGuardedRhs" (List [App "()" (List []),App "App" (List [App
    "()" (List []),App "Con" (List [App "()" (List []),App "UnQual" (
    List [App "()" (List []),App "Ident" (List [App "()" (List []),
    String "Error"])])]),App "Lit" (List [App "()" (List []),App
    "String" (List [App "()" (List []),String "...",String "..."])])])
    ]),App "Nothing" (List [])])]])]),App "InsDecl" (List [App "()" (
    List []),App "FunBind" (List [App "()" (List []),MapCtor (App
    "Match" (List [App "()" (List []),App "Ident" (List [App "()" (
    List []),String "showJSON"]),List [App "PParen" (List [App "()" (
    List []),App "PApp" (List [App "()" (List []),App "UnQual" (List [
    App "()" (List []),App "Ident" (List [App "()" (List []),CtorName]
    )]),MapField (App "PVar" (List [App "()" (List []),App "Ident" (
    List [App "()" (List []),Concat (List [String "x",ShowInt
    FieldIndex])])]))])])],App "UnGuardedRhs" (List [App "()" (List []
    ),App "SpliceExp" (List [App "()" (List []),App "ParenSplice" (
    List [App "()" (List []),App "App" (List [App "()" (List []),App
    "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List
    []),App "Ident" (List [App "()" (List []),String "showJSON"])])]),
    App "Lit" (List [App "()" (List []),App "Int" (List [App "()" (
    List []),CtorIndex,ShowInt CtorIndex])])])])])]),App "Nothing" (
    List [])]))])])]]))]
-- GENERATED STOP

-- ^ 'Derivation' for 'JSON'

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

------------------------------------------------------------------------------
-- showJSON

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 () H.Boxed [strE (ctorDeclName c), mkFields (ctorDeclFields c)]]

mkShowPlainFields :: FieldDecl -> Exp ()
mkShowPlainFields fs = mkJSArray $ H.List ()
    [H.App () (var "showJSON") xi | xi <- vars "x" fs]

mkShowRecordFields :: FieldDecl -> Exp ()
mkShowRecordFields fs = mkJSObject $ H.List ()
    [ H.Tuple () H.Boxed [strE fn, H.App () (var "showJSON") xi]
    | ((fn, _), xi) <- zip fs (vars "x" fs)]

------------------------------------------------------------------------------
-- readJSON

mkRead :: FullDataDecl -> Exp ()
mkRead (_, d) = let
    readError = H.App () (con "Error") $ strE "malformed JSON for type ...: ..."
  in
    H.Case () (H.App () (var "fromJSObject") $ var "x") $
    map mkReadCtor (dataDeclCtors d) ++
    [H.Alt () (H.PWildCard ()) (H.UnGuardedRhs () readError) Nothing]

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 () (H.PList () [H.PTuple () H.Boxed [strP cn, pVar "y"]])
         (H.UnGuardedRhs () body) Nothing

mkReadRecord :: String -> FieldDecl -> Exp ()
mkReadRecord cn fs = H.Do () $
    [H.Generator () (H.PApp () (qname "JSObject") [pVar "z"])
          (H.App () (var "return") $ var "y")] ++
    [H.LetStmt () $ H.BDecls () [H.PatBind () (pVar "d")
          (H.UnGuardedRhs () $ H.App () (var "fromJSObject") $ var "z")
          Nothing]] ++
    zipWith (mkReadRecordField cn) (pVars "x" fs) fs ++
    mkReadTrailer cn fs

mkReadRecordField :: String -> Pat () -> (String, Type ()) -> Stmt ()
mkReadRecordField cn xi (fn, _) = H.Generator () xi $
    apps (var "maybe") [
        H.App () (var "fail") $ 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 () (H.PApp () (qname "JSArray") [H.PList () (pVars "x" fs)])
        (H.App () (var "return") $ var "y")] ++
    mkReadTrailer cn fs

mkReadTrailer :: String -> FieldDecl -> [Stmt ()]
mkReadTrailer cn fs =
    [ H.Generator () yi (H.App () (var "readJSON") xi)
    | (xi, yi) <- zip (vars "x" fs) (pVars "y" fs)] ++
    [H.Qualifier () $ H.App () (var "return") $ apps (con cn) (vars "y" fs)]

------------------------------------------------------------------------------
-- utilites

mkJSObject :: Exp () -> Exp ()
mkJSObject e = H.App () (con "JSObject") (H.App () (var "toJSObject") e)

mkJSArray :: Exp () -> Exp ()
mkJSArray e = H.App () (con "JSArray") 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]]