-- |
-- 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, BangType, Stmt,
    (~=), var, pVar, con, strE, strP, apps, qname, sl,
    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" (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 []])]))])])])]
-- 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 [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)]

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

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)]

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

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]]