1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
|
-- |
-- 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 H.Boxed [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 H.Boxed [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 H.Boxed [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]]
|
