Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / THH.hs @ aa5b2f07

History | View | Annotate | Download (28.6 kB)

1 a1505857 Iustin Pop
{-# LANGUAGE TemplateHaskell #-}
2 e9aaa3c6 Iustin Pop
3 e9aaa3c6 Iustin Pop
{-| TemplateHaskell helper for HTools.
4 e9aaa3c6 Iustin Pop
5 e9aaa3c6 Iustin Pop
As TemplateHaskell require that splices be defined in a separate
6 e9aaa3c6 Iustin Pop
module, we combine all the TemplateHaskell functionality that HTools
7 e9aaa3c6 Iustin Pop
needs in this module (except the one for unittests).
8 e9aaa3c6 Iustin Pop
9 e9aaa3c6 Iustin Pop
-}
10 e9aaa3c6 Iustin Pop
11 e9aaa3c6 Iustin Pop
{-
12 e9aaa3c6 Iustin Pop
13 e9aaa3c6 Iustin Pop
Copyright (C) 2011 Google Inc.
14 e9aaa3c6 Iustin Pop
15 e9aaa3c6 Iustin Pop
This program is free software; you can redistribute it and/or modify
16 e9aaa3c6 Iustin Pop
it under the terms of the GNU General Public License as published by
17 e9aaa3c6 Iustin Pop
the Free Software Foundation; either version 2 of the License, or
18 e9aaa3c6 Iustin Pop
(at your option) any later version.
19 e9aaa3c6 Iustin Pop
20 e9aaa3c6 Iustin Pop
This program is distributed in the hope that it will be useful, but
21 e9aaa3c6 Iustin Pop
WITHOUT ANY WARRANTY; without even the implied warranty of
22 e9aaa3c6 Iustin Pop
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
23 e9aaa3c6 Iustin Pop
General Public License for more details.
24 e9aaa3c6 Iustin Pop
25 e9aaa3c6 Iustin Pop
You should have received a copy of the GNU General Public License
26 e9aaa3c6 Iustin Pop
along with this program; if not, write to the Free Software
27 e9aaa3c6 Iustin Pop
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
28 e9aaa3c6 Iustin Pop
02110-1301, USA.
29 e9aaa3c6 Iustin Pop
30 e9aaa3c6 Iustin Pop
-}
31 e9aaa3c6 Iustin Pop
32 b20cbf06 Iustin Pop
module Ganeti.THH ( declareSADT
33 260d0bda Agata Murawska
                  , declareIADT
34 e9aaa3c6 Iustin Pop
                  , makeJSONInstance
35 6111e296 Iustin Pop
                  , genOpID
36 12c19659 Iustin Pop
                  , genOpCode
37 a0090487 Agata Murawska
                  , genStrOfOp
38 a0090487 Agata Murawska
                  , genStrOfKey
39 a0090487 Agata Murawska
                  , genLuxiOp
40 879273e3 Iustin Pop
                  , Field
41 879273e3 Iustin Pop
                  , simpleField
42 879273e3 Iustin Pop
                  , defaultField
43 879273e3 Iustin Pop
                  , optionalField
44 879273e3 Iustin Pop
                  , renameField
45 879273e3 Iustin Pop
                  , containerField
46 879273e3 Iustin Pop
                  , customField
47 879273e3 Iustin Pop
                  , timeStampFields
48 879273e3 Iustin Pop
                  , uuidFields
49 879273e3 Iustin Pop
                  , serialFields
50 879273e3 Iustin Pop
                  , buildObject
51 879273e3 Iustin Pop
                  , buildObjectSerialisation
52 879273e3 Iustin Pop
                  , buildParam
53 879273e3 Iustin Pop
                  , Container
54 e9aaa3c6 Iustin Pop
                  ) where
55 e9aaa3c6 Iustin Pop
56 879273e3 Iustin Pop
import Control.Arrow
57 60de49c3 Iustin Pop
import Control.Monad (liftM, liftM2)
58 e9aaa3c6 Iustin Pop
import Data.Char
59 6111e296 Iustin Pop
import Data.List
60 879273e3 Iustin Pop
import qualified Data.Map as M
61 e9aaa3c6 Iustin Pop
import Language.Haskell.TH
62 e9aaa3c6 Iustin Pop
63 e9aaa3c6 Iustin Pop
import qualified Text.JSON as JSON
64 e9aaa3c6 Iustin Pop
65 706f7f51 Iustin Pop
import Ganeti.HTools.JSON
66 706f7f51 Iustin Pop
67 879273e3 Iustin Pop
-- * Exported types
68 879273e3 Iustin Pop
69 879273e3 Iustin Pop
type Container = M.Map String
70 879273e3 Iustin Pop
71 879273e3 Iustin Pop
-- | Serialised field data type.
72 879273e3 Iustin Pop
data Field = Field { fieldName        :: String
73 879273e3 Iustin Pop
                   , fieldType        :: Q Type
74 879273e3 Iustin Pop
                   , fieldRead        :: Maybe (Q Exp)
75 879273e3 Iustin Pop
                   , fieldShow        :: Maybe (Q Exp)
76 879273e3 Iustin Pop
                   , fieldDefault     :: Maybe (Q Exp)
77 879273e3 Iustin Pop
                   , fieldConstr      :: Maybe String
78 879273e3 Iustin Pop
                   , fieldIsContainer :: Bool
79 879273e3 Iustin Pop
                   , fieldIsOptional  :: Bool
80 879273e3 Iustin Pop
                   }
81 879273e3 Iustin Pop
82 879273e3 Iustin Pop
-- | Generates a simple field.
83 879273e3 Iustin Pop
simpleField :: String -> Q Type -> Field
84 879273e3 Iustin Pop
simpleField fname ftype =
85 879273e3 Iustin Pop
  Field { fieldName        = fname
86 879273e3 Iustin Pop
        , fieldType        = ftype
87 879273e3 Iustin Pop
        , fieldRead        = Nothing
88 879273e3 Iustin Pop
        , fieldShow        = Nothing
89 879273e3 Iustin Pop
        , fieldDefault     = Nothing
90 879273e3 Iustin Pop
        , fieldConstr      = Nothing
91 879273e3 Iustin Pop
        , fieldIsContainer = False
92 879273e3 Iustin Pop
        , fieldIsOptional  = False
93 879273e3 Iustin Pop
        }
94 879273e3 Iustin Pop
95 879273e3 Iustin Pop
-- | Sets the renamed constructor field.
96 879273e3 Iustin Pop
renameField :: String -> Field -> Field
97 879273e3 Iustin Pop
renameField constrName field = field { fieldConstr = Just constrName }
98 879273e3 Iustin Pop
99 879273e3 Iustin Pop
-- | Sets the default value on a field (makes it optional with a
100 879273e3 Iustin Pop
-- default value).
101 879273e3 Iustin Pop
defaultField :: Q Exp -> Field -> Field
102 879273e3 Iustin Pop
defaultField defval field = field { fieldDefault = Just defval }
103 879273e3 Iustin Pop
104 879273e3 Iustin Pop
-- | Marks a field optional (turning its base type into a Maybe).
105 879273e3 Iustin Pop
optionalField :: Field -> Field
106 879273e3 Iustin Pop
optionalField field = field { fieldIsOptional = True }
107 879273e3 Iustin Pop
108 879273e3 Iustin Pop
-- | Marks a field as a container.
109 879273e3 Iustin Pop
containerField :: Field -> Field
110 879273e3 Iustin Pop
containerField field = field { fieldIsContainer = True }
111 879273e3 Iustin Pop
112 879273e3 Iustin Pop
-- | Sets custom functions on a field.
113 879273e3 Iustin Pop
customField :: Q Exp -> Q Exp -> Field -> Field
114 879273e3 Iustin Pop
customField readfn showfn field =
115 879273e3 Iustin Pop
  field { fieldRead = Just readfn, fieldShow = Just showfn }
116 879273e3 Iustin Pop
117 879273e3 Iustin Pop
fieldRecordName :: Field -> String
118 879273e3 Iustin Pop
fieldRecordName (Field { fieldName = name, fieldConstr = alias }) =
119 879273e3 Iustin Pop
  maybe (camelCase name) id alias
120 879273e3 Iustin Pop
121 a1505857 Iustin Pop
-- | Computes the preferred variable name to use for the value of this
122 a1505857 Iustin Pop
-- field. If the field has a specific constructor name, then we use a
123 a1505857 Iustin Pop
-- first-letter-lowercased version of that; otherwise, we simply use
124 a1505857 Iustin Pop
-- the field name. See also 'fieldRecordName'.
125 879273e3 Iustin Pop
fieldVariable :: Field -> String
126 a1505857 Iustin Pop
fieldVariable f =
127 a1505857 Iustin Pop
  case (fieldConstr f) of
128 a1505857 Iustin Pop
    Just name -> ensureLower name
129 a1505857 Iustin Pop
    _ -> fieldName f
130 879273e3 Iustin Pop
131 879273e3 Iustin Pop
actualFieldType :: Field -> Q Type
132 879273e3 Iustin Pop
actualFieldType f | fieldIsContainer f = [t| Container $t |]
133 879273e3 Iustin Pop
                  | fieldIsOptional f  = [t| Maybe $t     |]
134 879273e3 Iustin Pop
                  | otherwise = t
135 879273e3 Iustin Pop
                  where t = fieldType f
136 879273e3 Iustin Pop
137 879273e3 Iustin Pop
checkNonOptDef :: (Monad m) => Field -> m ()
138 879273e3 Iustin Pop
checkNonOptDef (Field { fieldIsOptional = True, fieldName = name }) =
139 879273e3 Iustin Pop
  fail $ "Optional field " ++ name ++ " used in parameter declaration"
140 879273e3 Iustin Pop
checkNonOptDef (Field { fieldDefault = (Just _), fieldName = name }) =
141 879273e3 Iustin Pop
  fail $ "Default field " ++ name ++ " used in parameter declaration"
142 879273e3 Iustin Pop
checkNonOptDef _ = return ()
143 879273e3 Iustin Pop
144 879273e3 Iustin Pop
loadFn :: Field -> Q Exp -> Q Exp
145 879273e3 Iustin Pop
loadFn (Field { fieldIsContainer = True }) expr = [| $expr >>= readContainer |]
146 879273e3 Iustin Pop
loadFn (Field { fieldRead = Just readfn }) expr = [| $expr >>= $readfn |]
147 879273e3 Iustin Pop
loadFn _ expr = expr
148 879273e3 Iustin Pop
149 879273e3 Iustin Pop
saveFn :: Field -> Q Exp -> Q Exp
150 879273e3 Iustin Pop
saveFn (Field { fieldIsContainer = True }) expr = [| showContainer $expr |]
151 879273e3 Iustin Pop
saveFn (Field { fieldRead = Just readfn }) expr = [| $readfn $expr |]
152 879273e3 Iustin Pop
saveFn _ expr = expr
153 879273e3 Iustin Pop
154 879273e3 Iustin Pop
-- * Common field declarations
155 879273e3 Iustin Pop
156 879273e3 Iustin Pop
timeStampFields :: [Field]
157 879273e3 Iustin Pop
timeStampFields =
158 879273e3 Iustin Pop
    [ defaultField [| 0::Double |] $ simpleField "ctime" [t| Double |]
159 879273e3 Iustin Pop
    , defaultField [| 0::Double |] $ simpleField "mtime" [t| Double |]
160 879273e3 Iustin Pop
    ]
161 879273e3 Iustin Pop
162 879273e3 Iustin Pop
serialFields :: [Field]
163 879273e3 Iustin Pop
serialFields =
164 879273e3 Iustin Pop
    [ renameField  "Serial" $ simpleField "serial_no" [t| Int |] ]
165 879273e3 Iustin Pop
166 879273e3 Iustin Pop
uuidFields :: [Field]
167 879273e3 Iustin Pop
uuidFields = [ simpleField "uuid" [t| String |] ]
168 879273e3 Iustin Pop
169 53664e15 Iustin Pop
-- * Helper functions
170 53664e15 Iustin Pop
171 e9aaa3c6 Iustin Pop
-- | Ensure first letter is lowercase.
172 e9aaa3c6 Iustin Pop
--
173 e9aaa3c6 Iustin Pop
-- Used to convert type name to function prefix, e.g. in @data Aa ->
174 5f828ce4 Agata Murawska
-- aaToRaw@.
175 e9aaa3c6 Iustin Pop
ensureLower :: String -> String
176 e9aaa3c6 Iustin Pop
ensureLower [] = []
177 e9aaa3c6 Iustin Pop
ensureLower (x:xs) = toLower x:xs
178 e9aaa3c6 Iustin Pop
179 879273e3 Iustin Pop
-- | Ensure first letter is uppercase.
180 879273e3 Iustin Pop
--
181 879273e3 Iustin Pop
-- Used to convert constructor name to component
182 879273e3 Iustin Pop
ensureUpper :: String -> String
183 879273e3 Iustin Pop
ensureUpper [] = []
184 879273e3 Iustin Pop
ensureUpper (x:xs) = toUpper x:xs
185 879273e3 Iustin Pop
186 53664e15 Iustin Pop
-- | Helper for quoted expressions.
187 53664e15 Iustin Pop
varNameE :: String -> Q Exp
188 53664e15 Iustin Pop
varNameE = varE . mkName
189 53664e15 Iustin Pop
190 53664e15 Iustin Pop
-- | showJSON as an expression, for reuse.
191 53664e15 Iustin Pop
showJSONE :: Q Exp
192 53664e15 Iustin Pop
showJSONE = varNameE "showJSON"
193 53664e15 Iustin Pop
194 5f828ce4 Agata Murawska
-- | ToRaw function name.
195 5f828ce4 Agata Murawska
toRawName :: String -> Name
196 5f828ce4 Agata Murawska
toRawName = mkName . (++ "ToRaw") . ensureLower
197 e9aaa3c6 Iustin Pop
198 5f828ce4 Agata Murawska
-- | FromRaw function name.
199 5f828ce4 Agata Murawska
fromRawName :: String -> Name
200 5f828ce4 Agata Murawska
fromRawName = mkName . (++ "FromRaw") . ensureLower
201 260d0bda Agata Murawska
202 6111e296 Iustin Pop
-- | Converts a name to it's varE/litE representations.
203 6111e296 Iustin Pop
--
204 6111e296 Iustin Pop
reprE :: Either String Name -> Q Exp
205 53664e15 Iustin Pop
reprE = either stringE varE
206 53664e15 Iustin Pop
207 60de49c3 Iustin Pop
-- | Smarter function application.
208 60de49c3 Iustin Pop
--
209 60de49c3 Iustin Pop
-- This does simply f x, except that if is 'id', it will skip it, in
210 60de49c3 Iustin Pop
-- order to generate more readable code when using -ddump-splices.
211 60de49c3 Iustin Pop
appFn :: Exp -> Exp -> Exp
212 60de49c3 Iustin Pop
appFn f x | f == VarE 'id = x
213 60de49c3 Iustin Pop
          | otherwise = AppE f x
214 60de49c3 Iustin Pop
215 879273e3 Iustin Pop
-- | Container loader
216 706f7f51 Iustin Pop
readContainer :: (Monad m, JSON.JSON a) =>
217 706f7f51 Iustin Pop
                 JSON.JSObject JSON.JSValue -> m (Container a)
218 706f7f51 Iustin Pop
readContainer obj = do
219 706f7f51 Iustin Pop
  let kjvlist = JSON.fromJSObject obj
220 706f7f51 Iustin Pop
  kalist <- mapM (\(k, v) -> fromKeyValue k v >>= \a -> return (k, a)) kjvlist
221 706f7f51 Iustin Pop
  return $ M.fromList kalist
222 879273e3 Iustin Pop
223 879273e3 Iustin Pop
-- | Container dumper
224 879273e3 Iustin Pop
showContainer :: (JSON.JSON a) => Container a -> JSON.JSValue
225 879273e3 Iustin Pop
showContainer = JSON.makeObj . map (second JSON.showJSON) . M.toList
226 879273e3 Iustin Pop
227 5f828ce4 Agata Murawska
-- * Template code for simple raw type-equivalent ADTs
228 6111e296 Iustin Pop
229 e9aaa3c6 Iustin Pop
-- | Generates a data type declaration.
230 e9aaa3c6 Iustin Pop
--
231 e9aaa3c6 Iustin Pop
-- The type will have a fixed list of instances.
232 e9aaa3c6 Iustin Pop
strADTDecl :: Name -> [String] -> Dec
233 e9aaa3c6 Iustin Pop
strADTDecl name constructors =
234 ebf38064 Iustin Pop
  DataD [] name []
235 ebf38064 Iustin Pop
          (map (flip NormalC [] . mkName) constructors)
236 ebf38064 Iustin Pop
          [''Show, ''Read, ''Eq, ''Enum, ''Bounded, ''Ord]
237 e9aaa3c6 Iustin Pop
238 5f828ce4 Agata Murawska
-- | Generates a toRaw function.
239 e9aaa3c6 Iustin Pop
--
240 e9aaa3c6 Iustin Pop
-- This generates a simple function of the form:
241 e9aaa3c6 Iustin Pop
--
242 e9aaa3c6 Iustin Pop
-- @
243 5f828ce4 Agata Murawska
-- nameToRaw :: Name -> /traw/
244 5f828ce4 Agata Murawska
-- nameToRaw Cons1 = var1
245 5f828ce4 Agata Murawska
-- nameToRaw Cons2 = \"value2\"
246 e9aaa3c6 Iustin Pop
-- @
247 5f828ce4 Agata Murawska
genToRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec]
248 5f828ce4 Agata Murawska
genToRaw traw fname tname constructors = do
249 5f828ce4 Agata Murawska
  sigt <- [t| $(conT tname) -> $(conT traw) |]
250 e9aaa3c6 Iustin Pop
  -- the body clauses, matching on the constructor and returning the
251 5f828ce4 Agata Murawska
  -- raw value
252 e9aaa3c6 Iustin Pop
  clauses <- mapM  (\(c, v) -> clause [recP (mkName c) []]
253 6111e296 Iustin Pop
                             (normalB (reprE v)) []) constructors
254 e9aaa3c6 Iustin Pop
  return [SigD fname sigt, FunD fname clauses]
255 e9aaa3c6 Iustin Pop
256 5f828ce4 Agata Murawska
-- | Generates a fromRaw function.
257 e9aaa3c6 Iustin Pop
--
258 e9aaa3c6 Iustin Pop
-- The function generated is monadic and can fail parsing the
259 5f828ce4 Agata Murawska
-- raw value. It is of the form:
260 e9aaa3c6 Iustin Pop
--
261 e9aaa3c6 Iustin Pop
-- @
262 5f828ce4 Agata Murawska
-- nameFromRaw :: (Monad m) => /traw/ -> m Name
263 5f828ce4 Agata Murawska
-- nameFromRaw s | s == var1       = Cons1
264 5f828ce4 Agata Murawska
--               | s == \"value2\" = Cons2
265 5f828ce4 Agata Murawska
--               | otherwise = fail /.../
266 e9aaa3c6 Iustin Pop
-- @
267 5f828ce4 Agata Murawska
genFromRaw :: Name -> Name -> Name -> [(String, Name)] -> Q [Dec]
268 5f828ce4 Agata Murawska
genFromRaw traw fname tname constructors = do
269 e9aaa3c6 Iustin Pop
  -- signature of form (Monad m) => String -> m $name
270 5f828ce4 Agata Murawska
  sigt <- [t| (Monad m) => $(conT traw) -> m $(conT tname) |]
271 e9aaa3c6 Iustin Pop
  -- clauses for a guarded pattern
272 e9aaa3c6 Iustin Pop
  let varp = mkName "s"
273 e9aaa3c6 Iustin Pop
      varpe = varE varp
274 e9aaa3c6 Iustin Pop
  clauses <- mapM (\(c, v) -> do
275 e9aaa3c6 Iustin Pop
                     -- the clause match condition
276 e9aaa3c6 Iustin Pop
                     g <- normalG [| $varpe == $(varE v) |]
277 e9aaa3c6 Iustin Pop
                     -- the clause result
278 e9aaa3c6 Iustin Pop
                     r <- [| return $(conE (mkName c)) |]
279 e9aaa3c6 Iustin Pop
                     return (g, r)) constructors
280 e9aaa3c6 Iustin Pop
  -- the otherwise clause (fallback)
281 e9aaa3c6 Iustin Pop
  oth_clause <- do
282 e9aaa3c6 Iustin Pop
    g <- normalG [| otherwise |]
283 e9aaa3c6 Iustin Pop
    r <- [|fail ("Invalid string value for type " ++
284 5f828ce4 Agata Murawska
                 $(litE (stringL (nameBase tname))) ++ ": " ++ show $varpe) |]
285 e9aaa3c6 Iustin Pop
    return (g, r)
286 e9aaa3c6 Iustin Pop
  let fun = FunD fname [Clause [VarP varp]
287 e9aaa3c6 Iustin Pop
                        (GuardedB (clauses++[oth_clause])) []]
288 e9aaa3c6 Iustin Pop
  return [SigD fname sigt, fun]
289 e9aaa3c6 Iustin Pop
290 5f828ce4 Agata Murawska
-- | Generates a data type from a given raw format.
291 e9aaa3c6 Iustin Pop
--
292 e9aaa3c6 Iustin Pop
-- The format is expected to multiline. The first line contains the
293 e9aaa3c6 Iustin Pop
-- type name, and the rest of the lines must contain two words: the
294 e9aaa3c6 Iustin Pop
-- constructor name and then the string representation of the
295 e9aaa3c6 Iustin Pop
-- respective constructor.
296 e9aaa3c6 Iustin Pop
--
297 e9aaa3c6 Iustin Pop
-- The function will generate the data type declaration, and then two
298 e9aaa3c6 Iustin Pop
-- functions:
299 e9aaa3c6 Iustin Pop
--
300 5f828ce4 Agata Murawska
-- * /name/ToRaw, which converts the type to a raw type
301 e9aaa3c6 Iustin Pop
--
302 5f828ce4 Agata Murawska
-- * /name/FromRaw, which (monadically) converts from a raw type to the type
303 e9aaa3c6 Iustin Pop
--
304 e9aaa3c6 Iustin Pop
-- Note that this is basically just a custom show/read instance,
305 e9aaa3c6 Iustin Pop
-- nothing else.
306 5f828ce4 Agata Murawska
declareADT :: Name -> String -> [(String, Name)] -> Q [Dec]
307 5f828ce4 Agata Murawska
declareADT traw sname cons = do
308 e9aaa3c6 Iustin Pop
  let name = mkName sname
309 e9aaa3c6 Iustin Pop
      ddecl = strADTDecl name (map fst cons)
310 5f828ce4 Agata Murawska
      -- process cons in the format expected by genToRaw
311 6111e296 Iustin Pop
      cons' = map (\(a, b) -> (a, Right b)) cons
312 5f828ce4 Agata Murawska
  toraw <- genToRaw traw (toRawName sname) name cons'
313 5f828ce4 Agata Murawska
  fromraw <- genFromRaw traw (fromRawName sname) name cons
314 5f828ce4 Agata Murawska
  return $ ddecl:toraw ++ fromraw
315 e9aaa3c6 Iustin Pop
316 5f828ce4 Agata Murawska
declareIADT :: String -> [(String, Name)] -> Q [Dec]
317 5f828ce4 Agata Murawska
declareIADT = declareADT ''Int
318 5f828ce4 Agata Murawska
319 5f828ce4 Agata Murawska
declareSADT :: String -> [(String, Name)] -> Q [Dec]
320 5f828ce4 Agata Murawska
declareSADT = declareADT ''String
321 e9aaa3c6 Iustin Pop
322 e9aaa3c6 Iustin Pop
-- | Creates the showJSON member of a JSON instance declaration.
323 e9aaa3c6 Iustin Pop
--
324 e9aaa3c6 Iustin Pop
-- This will create what is the equivalent of:
325 e9aaa3c6 Iustin Pop
--
326 e9aaa3c6 Iustin Pop
-- @
327 5f828ce4 Agata Murawska
-- showJSON = showJSON . /name/ToRaw
328 e9aaa3c6 Iustin Pop
-- @
329 e9aaa3c6 Iustin Pop
--
330 e9aaa3c6 Iustin Pop
-- in an instance JSON /name/ declaration
331 e9aaa3c6 Iustin Pop
genShowJSON :: String -> Q [Dec]
332 5f828ce4 Agata Murawska
genShowJSON name = [d| showJSON = JSON.showJSON . $(varE (toRawName name)) |]
333 e9aaa3c6 Iustin Pop
334 e9aaa3c6 Iustin Pop
-- | Creates the readJSON member of a JSON instance declaration.
335 e9aaa3c6 Iustin Pop
--
336 e9aaa3c6 Iustin Pop
-- This will create what is the equivalent of:
337 e9aaa3c6 Iustin Pop
--
338 e9aaa3c6 Iustin Pop
-- @
339 e9aaa3c6 Iustin Pop
-- readJSON s = case readJSON s of
340 5f828ce4 Agata Murawska
--                Ok s' -> /name/FromRaw s'
341 e9aaa3c6 Iustin Pop
--                Error e -> Error /description/
342 e9aaa3c6 Iustin Pop
-- @
343 e9aaa3c6 Iustin Pop
--
344 e9aaa3c6 Iustin Pop
-- in an instance JSON /name/ declaration
345 e9aaa3c6 Iustin Pop
genReadJSON :: String -> Q Dec
346 e9aaa3c6 Iustin Pop
genReadJSON name = do
347 e9aaa3c6 Iustin Pop
  let s = mkName "s"
348 e9aaa3c6 Iustin Pop
  body <- [| case JSON.readJSON $(varE s) of
349 5f828ce4 Agata Murawska
               JSON.Ok s' -> $(varE (fromRawName name)) s'
350 e9aaa3c6 Iustin Pop
               JSON.Error e ->
351 5f828ce4 Agata Murawska
                   JSON.Error $ "Can't parse raw value for type " ++
352 6bd26f00 Iustin Pop
                           $(stringE name) ++ ": " ++ e ++ " from " ++
353 6bd26f00 Iustin Pop
                           show $(varE s)
354 e9aaa3c6 Iustin Pop
           |]
355 e9aaa3c6 Iustin Pop
  return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []]
356 e9aaa3c6 Iustin Pop
357 e9aaa3c6 Iustin Pop
-- | Generates a JSON instance for a given type.
358 e9aaa3c6 Iustin Pop
--
359 5f828ce4 Agata Murawska
-- This assumes that the /name/ToRaw and /name/FromRaw functions
360 e9aaa3c6 Iustin Pop
-- have been defined as by the 'declareSADT' function.
361 e9aaa3c6 Iustin Pop
makeJSONInstance :: Name -> Q [Dec]
362 e9aaa3c6 Iustin Pop
makeJSONInstance name = do
363 e9aaa3c6 Iustin Pop
  let base = nameBase name
364 e9aaa3c6 Iustin Pop
  showJ <- genShowJSON base
365 e9aaa3c6 Iustin Pop
  readJ <- genReadJSON base
366 e9aaa3c6 Iustin Pop
  return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) (readJ:showJ)]
367 6111e296 Iustin Pop
368 53664e15 Iustin Pop
-- * Template code for opcodes
369 53664e15 Iustin Pop
370 6111e296 Iustin Pop
-- | Transforms a CamelCase string into an_underscore_based_one.
371 6111e296 Iustin Pop
deCamelCase :: String -> String
372 6111e296 Iustin Pop
deCamelCase =
373 6111e296 Iustin Pop
    intercalate "_" . map (map toUpper) . groupBy (\_ b -> not $ isUpper b)
374 6111e296 Iustin Pop
375 879273e3 Iustin Pop
-- | Transform an underscore_name into a CamelCase one.
376 879273e3 Iustin Pop
camelCase :: String -> String
377 879273e3 Iustin Pop
camelCase = concatMap (ensureUpper . drop 1) .
378 879273e3 Iustin Pop
            groupBy (\_ b -> b /= '_') . ('_':)
379 879273e3 Iustin Pop
380 05ff7a00 Agata Murawska
-- | Computes the name of a given constructor.
381 6111e296 Iustin Pop
constructorName :: Con -> Q Name
382 6111e296 Iustin Pop
constructorName (NormalC name _) = return name
383 6111e296 Iustin Pop
constructorName (RecC name _)    = return name
384 6111e296 Iustin Pop
constructorName x                = fail $ "Unhandled constructor " ++ show x
385 6111e296 Iustin Pop
386 a0090487 Agata Murawska
-- | Builds the generic constructor-to-string function.
387 6111e296 Iustin Pop
--
388 6111e296 Iustin Pop
-- This generates a simple function of the following form:
389 6111e296 Iustin Pop
--
390 6111e296 Iustin Pop
-- @
391 a0090487 Agata Murawska
-- fname (ConStructorOne {}) = trans_fun("ConStructorOne")
392 a0090487 Agata Murawska
-- fname (ConStructorTwo {}) = trans_fun("ConStructorTwo")
393 6111e296 Iustin Pop
-- @
394 6111e296 Iustin Pop
--
395 6111e296 Iustin Pop
-- This builds a custom list of name/string pairs and then uses
396 5f828ce4 Agata Murawska
-- 'genToRaw' to actually generate the function
397 a0090487 Agata Murawska
genConstrToStr :: (String -> String) -> Name -> String -> Q [Dec]
398 a0090487 Agata Murawska
genConstrToStr trans_fun name fname = do
399 6111e296 Iustin Pop
  TyConI (DataD _ _ _ cons _) <- reify name
400 6111e296 Iustin Pop
  cnames <- mapM (liftM nameBase . constructorName) cons
401 a0090487 Agata Murawska
  let svalues = map (Left . trans_fun) cnames
402 5f828ce4 Agata Murawska
  genToRaw ''String (mkName fname) name $ zip cnames svalues
403 12c19659 Iustin Pop
404 a0090487 Agata Murawska
-- | Constructor-to-string for OpCode.
405 a0090487 Agata Murawska
genOpID :: Name -> String -> Q [Dec]
406 a0090487 Agata Murawska
genOpID = genConstrToStr deCamelCase
407 12c19659 Iustin Pop
408 05ff7a00 Agata Murawska
-- | OpCode parameter (field) type.
409 12c19659 Iustin Pop
type OpParam = (String, Q Type, Q Exp)
410 12c19659 Iustin Pop
411 12c19659 Iustin Pop
-- | Generates the OpCode data type.
412 12c19659 Iustin Pop
--
413 12c19659 Iustin Pop
-- This takes an opcode logical definition, and builds both the
414 12c19659 Iustin Pop
-- datatype and the JSON serialisation out of it. We can't use a
415 12c19659 Iustin Pop
-- generic serialisation since we need to be compatible with Ganeti's
416 12c19659 Iustin Pop
-- own, so we have a few quirks to work around.
417 12c19659 Iustin Pop
genOpCode :: String                -- ^ Type name to use
418 a1505857 Iustin Pop
          -> [(String, [Field])]   -- ^ Constructor name and parameters
419 12c19659 Iustin Pop
          -> Q [Dec]
420 12c19659 Iustin Pop
genOpCode name cons = do
421 12c19659 Iustin Pop
  decl_d <- mapM (\(cname, fields) -> do
422 12c19659 Iustin Pop
                    -- we only need the type of the field, without Q
423 a1505857 Iustin Pop
                    fields' <- mapM actualFieldType fields
424 a1505857 Iustin Pop
                    let fields'' = zip (repeat NotStrict) fields'
425 a1505857 Iustin Pop
                    return $ NormalC (mkName cname) fields'')
426 12c19659 Iustin Pop
            cons
427 12c19659 Iustin Pop
  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq]
428 12c19659 Iustin Pop
429 12c19659 Iustin Pop
  (savesig, savefn) <- genSaveOpCode cons
430 12c19659 Iustin Pop
  (loadsig, loadfn) <- genLoadOpCode cons
431 12c19659 Iustin Pop
  return [declD, loadsig, loadfn, savesig, savefn]
432 12c19659 Iustin Pop
433 05ff7a00 Agata Murawska
-- | Checks whether a given parameter is options.
434 12c19659 Iustin Pop
--
435 12c19659 Iustin Pop
-- This requires that it's a 'Maybe'.
436 12c19659 Iustin Pop
isOptional :: Type -> Bool
437 12c19659 Iustin Pop
isOptional (AppT (ConT dt) _) | dt == ''Maybe = True
438 12c19659 Iustin Pop
isOptional _ = False
439 12c19659 Iustin Pop
440 12c19659 Iustin Pop
-- | Generates the \"save\" clause for an entire opcode constructor.
441 12c19659 Iustin Pop
--
442 12c19659 Iustin Pop
-- This matches the opcode with variables named the same as the
443 12c19659 Iustin Pop
-- constructor fields (just so that the spliced in code looks nicer),
444 a1505857 Iustin Pop
-- and passes those name plus the parameter definition to 'saveObjectField'.
445 12c19659 Iustin Pop
saveConstructor :: String    -- ^ The constructor name
446 a1505857 Iustin Pop
                -> [Field]   -- ^ The parameter definitions for this
447 12c19659 Iustin Pop
                             -- constructor
448 12c19659 Iustin Pop
                -> Q Clause  -- ^ Resulting clause
449 12c19659 Iustin Pop
saveConstructor sname fields = do
450 12c19659 Iustin Pop
  let cname = mkName sname
451 a1505857 Iustin Pop
  let fnames = map (mkName . fieldVariable) fields
452 12c19659 Iustin Pop
  let pat = conP cname (map varP fnames)
453 a1505857 Iustin Pop
  let felems = map (uncurry saveObjectField) (zip fnames fields)
454 12c19659 Iustin Pop
      -- now build the OP_ID serialisation
455 53664e15 Iustin Pop
      opid = [| [( $(stringE "OP_ID"),
456 a07343b2 Iustin Pop
                   JSON.showJSON $(stringE . deCamelCase $ sname) )] |]
457 12c19659 Iustin Pop
      flist = listE (opid:felems)
458 12c19659 Iustin Pop
      -- and finally convert all this to a json object
459 53664e15 Iustin Pop
      flist' = [| $(varNameE "makeObj") (concat $flist) |]
460 12c19659 Iustin Pop
  clause [pat] (normalB flist') []
461 12c19659 Iustin Pop
462 12c19659 Iustin Pop
-- | Generates the main save opcode function.
463 12c19659 Iustin Pop
--
464 12c19659 Iustin Pop
-- This builds a per-constructor match clause that contains the
465 12c19659 Iustin Pop
-- respective constructor-serialisation code.
466 a1505857 Iustin Pop
genSaveOpCode :: [(String, [Field])] -> Q (Dec, Dec)
467 12c19659 Iustin Pop
genSaveOpCode opdefs = do
468 12c19659 Iustin Pop
  cclauses <- mapM (uncurry saveConstructor) opdefs
469 12c19659 Iustin Pop
  let fname = mkName "saveOpCode"
470 12c19659 Iustin Pop
  sigt <- [t| $(conT (mkName "OpCode")) -> JSON.JSValue |]
471 12c19659 Iustin Pop
  return $ (SigD fname sigt, FunD fname cclauses)
472 12c19659 Iustin Pop
473 a1505857 Iustin Pop
loadConstructor :: String -> [Field] -> Q Exp
474 12c19659 Iustin Pop
loadConstructor sname fields = do
475 12c19659 Iustin Pop
  let name = mkName sname
476 a1505857 Iustin Pop
  fbinds <- mapM loadObjectField fields
477 12c19659 Iustin Pop
  let (fnames, fstmts) = unzip fbinds
478 12c19659 Iustin Pop
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
479 12c19659 Iustin Pop
      fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
480 12c19659 Iustin Pop
  return $ DoE fstmts'
481 12c19659 Iustin Pop
482 a1505857 Iustin Pop
genLoadOpCode :: [(String, [Field])] -> Q (Dec, Dec)
483 12c19659 Iustin Pop
genLoadOpCode opdefs = do
484 12c19659 Iustin Pop
  let fname = mkName "loadOpCode"
485 12c19659 Iustin Pop
      arg1 = mkName "v"
486 12c19659 Iustin Pop
      objname = mkName "o"
487 12c19659 Iustin Pop
      opid = mkName "op_id"
488 12c19659 Iustin Pop
  st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
489 12c19659 Iustin Pop
                                 (JSON.readJSON $(varE arg1)) |]
490 53664e15 Iustin Pop
  st2 <- bindS (varP opid) [| $(varNameE "fromObj")
491 53664e15 Iustin Pop
                              $(varE objname) $(stringE "OP_ID") |]
492 12c19659 Iustin Pop
  -- the match results (per-constructor blocks)
493 12c19659 Iustin Pop
  mexps <- mapM (uncurry loadConstructor) opdefs
494 12c19659 Iustin Pop
  fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |]
495 12c19659 Iustin Pop
  let mpats = map (\(me, c) ->
496 12c19659 Iustin Pop
                       let mp = LitP . StringL . deCamelCase . fst $ c
497 12c19659 Iustin Pop
                       in Match mp (NormalB me) []
498 12c19659 Iustin Pop
                  ) $ zip mexps opdefs
499 12c19659 Iustin Pop
      defmatch = Match WildP (NormalB fails) []
500 12c19659 Iustin Pop
      cst = NoBindS $ CaseE (VarE opid) $ mpats++[defmatch]
501 12c19659 Iustin Pop
      body = DoE [st1, st2, cst]
502 12c19659 Iustin Pop
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT (mkName "OpCode")) |]
503 12c19659 Iustin Pop
  return $ (SigD fname sigt, FunD fname [Clause [VarP arg1] (NormalB body) []])
504 12c19659 Iustin Pop
505 a0090487 Agata Murawska
-- * Template code for luxi
506 a0090487 Agata Murawska
507 a0090487 Agata Murawska
-- | Constructor-to-string for LuxiOp.
508 a0090487 Agata Murawska
genStrOfOp :: Name -> String -> Q [Dec]
509 a0090487 Agata Murawska
genStrOfOp = genConstrToStr id
510 a0090487 Agata Murawska
511 a0090487 Agata Murawska
-- | Constructor-to-string for MsgKeys.
512 a0090487 Agata Murawska
genStrOfKey :: Name -> String -> Q [Dec]
513 a0090487 Agata Murawska
genStrOfKey = genConstrToStr ensureLower
514 a0090487 Agata Murawska
515 a0090487 Agata Murawska
-- | LuxiOp parameter type.
516 a0090487 Agata Murawska
type LuxiParam = (String, Q Type, Q Exp)
517 a0090487 Agata Murawska
518 a0090487 Agata Murawska
-- | Generates the LuxiOp data type.
519 a0090487 Agata Murawska
--
520 a0090487 Agata Murawska
-- This takes a Luxi operation definition and builds both the
521 a0090487 Agata Murawska
-- datatype and the function trnasforming the arguments to JSON.
522 a0090487 Agata Murawska
-- We can't use anything less generic, because the way different
523 a0090487 Agata Murawska
-- operations are serialized differs on both parameter- and top-level.
524 a0090487 Agata Murawska
--
525 a0090487 Agata Murawska
-- There are three things to be defined for each parameter:
526 a0090487 Agata Murawska
--
527 a0090487 Agata Murawska
-- * name
528 a0090487 Agata Murawska
--
529 a0090487 Agata Murawska
-- * type
530 a0090487 Agata Murawska
--
531 a0090487 Agata Murawska
-- * operation; this is the operation performed on the parameter before
532 a0090487 Agata Murawska
--   serialization
533 a0090487 Agata Murawska
--
534 b20cbf06 Iustin Pop
genLuxiOp :: String -> [(String, [LuxiParam])] -> Q [Dec]
535 a0090487 Agata Murawska
genLuxiOp name cons = do
536 b20cbf06 Iustin Pop
  decl_d <- mapM (\(cname, fields) -> do
537 a0090487 Agata Murawska
                    fields' <- mapM (\(_, qt, _) ->
538 a0090487 Agata Murawska
                                         qt >>= \t -> return (NotStrict, t))
539 a0090487 Agata Murawska
                               fields
540 a0090487 Agata Murawska
                    return $ NormalC (mkName cname) fields')
541 a0090487 Agata Murawska
            cons
542 a0090487 Agata Murawska
  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read]
543 a0090487 Agata Murawska
  (savesig, savefn) <- genSaveLuxiOp cons
544 a0090487 Agata Murawska
  return [declD, savesig, savefn]
545 a0090487 Agata Murawska
546 92678b3c Iustin Pop
-- | Generates the \"save\" expression for a single luxi parameter.
547 b20cbf06 Iustin Pop
saveLuxiField :: Name -> LuxiParam -> Q Exp
548 b20cbf06 Iustin Pop
saveLuxiField fvar (_, qt, fn) =
549 b20cbf06 Iustin Pop
    [| JSON.showJSON ( $(liftM2 appFn fn $ varE fvar) ) |]
550 92678b3c Iustin Pop
551 a0090487 Agata Murawska
-- | Generates the \"save\" clause for entire LuxiOp constructor.
552 b20cbf06 Iustin Pop
saveLuxiConstructor :: (String, [LuxiParam]) -> Q Clause
553 b20cbf06 Iustin Pop
saveLuxiConstructor (sname, fields) = do
554 a0090487 Agata Murawska
  let cname = mkName sname
555 a0090487 Agata Murawska
      fnames = map (\(nm, _, _) -> mkName nm) fields
556 a0090487 Agata Murawska
      pat = conP cname (map varP fnames)
557 b20cbf06 Iustin Pop
      flist = map (uncurry saveLuxiField) (zip fnames fields)
558 b20cbf06 Iustin Pop
      finval = if null flist
559 b20cbf06 Iustin Pop
               then [| JSON.showJSON ()    |]
560 b20cbf06 Iustin Pop
               else [| JSON.showJSON $(listE flist) |]
561 92678b3c Iustin Pop
  clause [pat] (normalB finval) []
562 a0090487 Agata Murawska
563 a0090487 Agata Murawska
-- | Generates the main save LuxiOp function.
564 b20cbf06 Iustin Pop
genSaveLuxiOp :: [(String, [LuxiParam])]-> Q (Dec, Dec)
565 a0090487 Agata Murawska
genSaveLuxiOp opdefs = do
566 a0090487 Agata Murawska
  sigt <- [t| $(conT (mkName "LuxiOp")) -> JSON.JSValue |]
567 a0090487 Agata Murawska
  let fname = mkName "opToArgs"
568 a0090487 Agata Murawska
  cclauses <- mapM saveLuxiConstructor opdefs
569 a0090487 Agata Murawska
  return $ (SigD fname sigt, FunD fname cclauses)
570 879273e3 Iustin Pop
571 879273e3 Iustin Pop
-- * "Objects" functionality
572 879273e3 Iustin Pop
573 879273e3 Iustin Pop
-- | Extract the field's declaration from a Field structure.
574 879273e3 Iustin Pop
fieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
575 879273e3 Iustin Pop
fieldTypeInfo field_pfx fd = do
576 879273e3 Iustin Pop
  t <- actualFieldType fd
577 879273e3 Iustin Pop
  let n = mkName . (field_pfx ++) . fieldRecordName $ fd
578 879273e3 Iustin Pop
  return (n, NotStrict, t)
579 879273e3 Iustin Pop
580 879273e3 Iustin Pop
-- | Build an object declaration.
581 879273e3 Iustin Pop
buildObject :: String -> String -> [Field] -> Q [Dec]
582 879273e3 Iustin Pop
buildObject sname field_pfx fields = do
583 879273e3 Iustin Pop
  let name = mkName sname
584 879273e3 Iustin Pop
  fields_d <- mapM (fieldTypeInfo field_pfx) fields
585 879273e3 Iustin Pop
  let decl_d = RecC name fields_d
586 3c3c796e Iustin Pop
  let declD = DataD [] name [] [decl_d] [''Show, ''Read, ''Eq]
587 879273e3 Iustin Pop
  ser_decls <- buildObjectSerialisation sname fields
588 879273e3 Iustin Pop
  return $ declD:ser_decls
589 879273e3 Iustin Pop
590 879273e3 Iustin Pop
buildObjectSerialisation :: String -> [Field] -> Q [Dec]
591 879273e3 Iustin Pop
buildObjectSerialisation sname fields = do
592 879273e3 Iustin Pop
  let name = mkName sname
593 879273e3 Iustin Pop
  savedecls <- genSaveObject saveObjectField sname fields
594 879273e3 Iustin Pop
  (loadsig, loadfn) <- genLoadObject loadObjectField sname fields
595 879273e3 Iustin Pop
  shjson <- objectShowJSON sname
596 879273e3 Iustin Pop
  rdjson <- objectReadJSON sname
597 879273e3 Iustin Pop
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
598 879273e3 Iustin Pop
                 (rdjson:shjson)
599 879273e3 Iustin Pop
  return $ savedecls ++ [loadsig, loadfn, instdecl]
600 879273e3 Iustin Pop
601 879273e3 Iustin Pop
genSaveObject :: (Name -> Field -> Q Exp)
602 879273e3 Iustin Pop
              -> String -> [Field] -> Q [Dec]
603 879273e3 Iustin Pop
genSaveObject save_fn sname fields = do
604 879273e3 Iustin Pop
  let name = mkName sname
605 879273e3 Iustin Pop
  let fnames = map (mkName . fieldVariable) fields
606 879273e3 Iustin Pop
  let pat = conP name (map varP fnames)
607 879273e3 Iustin Pop
  let tdname = mkName ("toDict" ++ sname)
608 879273e3 Iustin Pop
  tdsigt <- [t| $(conT name) -> [(String, JSON.JSValue)] |]
609 879273e3 Iustin Pop
610 879273e3 Iustin Pop
  let felems = map (uncurry save_fn) (zip fnames fields)
611 879273e3 Iustin Pop
      flist = listE felems
612 879273e3 Iustin Pop
      -- and finally convert all this to a json object
613 879273e3 Iustin Pop
      tdlist = [| concat $flist |]
614 879273e3 Iustin Pop
      iname = mkName "i"
615 879273e3 Iustin Pop
  tclause <- clause [pat] (normalB tdlist) []
616 879273e3 Iustin Pop
  cclause <- [| $(varNameE "makeObj") . $(varE tdname) |]
617 879273e3 Iustin Pop
  let fname = mkName ("save" ++ sname)
618 879273e3 Iustin Pop
  sigt <- [t| $(conT name) -> JSON.JSValue |]
619 879273e3 Iustin Pop
  return [SigD tdname tdsigt, FunD tdname [tclause],
620 879273e3 Iustin Pop
          SigD fname sigt, ValD (VarP fname) (NormalB cclause) []]
621 879273e3 Iustin Pop
622 879273e3 Iustin Pop
saveObjectField :: Name -> Field -> Q Exp
623 879273e3 Iustin Pop
saveObjectField fvar field
624 a07343b2 Iustin Pop
  | isContainer = [| [( $nameE , JSON.showJSON . showContainer $ $fvarE)] |]
625 879273e3 Iustin Pop
  | fisOptional = [| case $(varE fvar) of
626 879273e3 Iustin Pop
                      Nothing -> []
627 a07343b2 Iustin Pop
                      Just v -> [( $nameE, JSON.showJSON v)]
628 879273e3 Iustin Pop
                  |]
629 879273e3 Iustin Pop
  | otherwise = case fieldShow field of
630 a07343b2 Iustin Pop
      Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |]
631 a07343b2 Iustin Pop
      Just fn -> [| [( $nameE, JSON.showJSON . $fn $ $fvarE)] |]
632 879273e3 Iustin Pop
  where isContainer = fieldIsContainer field
633 879273e3 Iustin Pop
        fisOptional  = fieldIsOptional field
634 879273e3 Iustin Pop
        nameE = stringE (fieldName field)
635 879273e3 Iustin Pop
        fvarE = varE fvar
636 879273e3 Iustin Pop
637 879273e3 Iustin Pop
objectShowJSON :: String -> Q [Dec]
638 879273e3 Iustin Pop
objectShowJSON name =
639 879273e3 Iustin Pop
  [d| showJSON = JSON.showJSON . $(varE . mkName $ "save" ++ name) |]
640 879273e3 Iustin Pop
641 879273e3 Iustin Pop
genLoadObject :: (Field -> Q (Name, Stmt))
642 879273e3 Iustin Pop
              -> String -> [Field] -> Q (Dec, Dec)
643 879273e3 Iustin Pop
genLoadObject load_fn sname fields = do
644 879273e3 Iustin Pop
  let name = mkName sname
645 879273e3 Iustin Pop
      funname = mkName $ "load" ++ sname
646 879273e3 Iustin Pop
      arg1 = mkName "v"
647 879273e3 Iustin Pop
      objname = mkName "o"
648 879273e3 Iustin Pop
      opid = mkName "op_id"
649 879273e3 Iustin Pop
  st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
650 879273e3 Iustin Pop
                                 (JSON.readJSON $(varE arg1)) |]
651 879273e3 Iustin Pop
  fbinds <- mapM load_fn fields
652 879273e3 Iustin Pop
  let (fnames, fstmts) = unzip fbinds
653 879273e3 Iustin Pop
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
654 879273e3 Iustin Pop
      fstmts' = st1:fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
655 879273e3 Iustin Pop
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT name) |]
656 879273e3 Iustin Pop
  return $ (SigD funname sigt,
657 879273e3 Iustin Pop
            FunD funname [Clause [VarP arg1] (NormalB (DoE fstmts')) []])
658 879273e3 Iustin Pop
659 879273e3 Iustin Pop
loadObjectField :: Field -> Q (Name, Stmt)
660 879273e3 Iustin Pop
loadObjectField field = do
661 879273e3 Iustin Pop
  let name = fieldVariable field
662 879273e3 Iustin Pop
      fvar = mkName name
663 879273e3 Iustin Pop
  -- these are used in all patterns below
664 879273e3 Iustin Pop
  let objvar = varNameE "o"
665 879273e3 Iustin Pop
      objfield = stringE (fieldName field)
666 879273e3 Iustin Pop
      loadexp =
667 879273e3 Iustin Pop
        if fieldIsOptional field
668 879273e3 Iustin Pop
          then [| $(varNameE "maybeFromObj") $objvar $objfield |]
669 879273e3 Iustin Pop
          else case fieldDefault field of
670 879273e3 Iustin Pop
                 Just defv ->
671 879273e3 Iustin Pop
                   [| $(varNameE "fromObjWithDefault") $objvar
672 879273e3 Iustin Pop
                      $objfield $defv |]
673 879273e3 Iustin Pop
                 Nothing -> [| $(varNameE "fromObj") $objvar $objfield |]
674 879273e3 Iustin Pop
  bexp <- loadFn field loadexp
675 879273e3 Iustin Pop
676 879273e3 Iustin Pop
  return (fvar, BindS (VarP fvar) bexp)
677 879273e3 Iustin Pop
678 879273e3 Iustin Pop
objectReadJSON :: String -> Q Dec
679 879273e3 Iustin Pop
objectReadJSON name = do
680 879273e3 Iustin Pop
  let s = mkName "s"
681 879273e3 Iustin Pop
  body <- [| case JSON.readJSON $(varE s) of
682 879273e3 Iustin Pop
               JSON.Ok s' -> $(varE .mkName $ "load" ++ name) s'
683 879273e3 Iustin Pop
               JSON.Error e ->
684 879273e3 Iustin Pop
                 JSON.Error $ "Can't parse value for type " ++
685 879273e3 Iustin Pop
                       $(stringE name) ++ ": " ++ e
686 879273e3 Iustin Pop
           |]
687 879273e3 Iustin Pop
  return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []]
688 879273e3 Iustin Pop
689 879273e3 Iustin Pop
-- * Inheritable parameter tables implementation
690 879273e3 Iustin Pop
691 879273e3 Iustin Pop
-- | Compute parameter type names.
692 879273e3 Iustin Pop
paramTypeNames :: String -> (String, String)
693 879273e3 Iustin Pop
paramTypeNames root = ("Filled"  ++ root ++ "Params",
694 879273e3 Iustin Pop
                       "Partial" ++ root ++ "Params")
695 879273e3 Iustin Pop
696 879273e3 Iustin Pop
-- | Compute information about the type of a parameter field.
697 879273e3 Iustin Pop
paramFieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
698 879273e3 Iustin Pop
paramFieldTypeInfo field_pfx fd = do
699 879273e3 Iustin Pop
  t <- actualFieldType fd
700 879273e3 Iustin Pop
  let n = mkName . (++ "P") . (field_pfx ++) .
701 879273e3 Iustin Pop
          fieldRecordName $ fd
702 879273e3 Iustin Pop
  return (n, NotStrict, AppT (ConT ''Maybe) t)
703 879273e3 Iustin Pop
704 879273e3 Iustin Pop
-- | Build a parameter declaration.
705 879273e3 Iustin Pop
--
706 879273e3 Iustin Pop
-- This function builds two different data structures: a /filled/ one,
707 879273e3 Iustin Pop
-- in which all fields are required, and a /partial/ one, in which all
708 879273e3 Iustin Pop
-- fields are optional. Due to the current record syntax issues, the
709 879273e3 Iustin Pop
-- fields need to be named differrently for the two structures, so the
710 879273e3 Iustin Pop
-- partial ones get a /P/ suffix.
711 879273e3 Iustin Pop
buildParam :: String -> String -> [Field] -> Q [Dec]
712 879273e3 Iustin Pop
buildParam sname field_pfx fields = do
713 879273e3 Iustin Pop
  let (sname_f, sname_p) = paramTypeNames sname
714 879273e3 Iustin Pop
      name_f = mkName sname_f
715 879273e3 Iustin Pop
      name_p = mkName sname_p
716 879273e3 Iustin Pop
  fields_f <- mapM (fieldTypeInfo field_pfx) fields
717 879273e3 Iustin Pop
  fields_p <- mapM (paramFieldTypeInfo field_pfx) fields
718 879273e3 Iustin Pop
  let decl_f = RecC name_f fields_f
719 879273e3 Iustin Pop
      decl_p = RecC name_p fields_p
720 879273e3 Iustin Pop
  let declF = DataD [] name_f [] [decl_f] [''Show, ''Read]
721 879273e3 Iustin Pop
      declP = DataD [] name_p [] [decl_p] [''Show, ''Read]
722 879273e3 Iustin Pop
  ser_decls_f <- buildObjectSerialisation sname_f fields
723 879273e3 Iustin Pop
  ser_decls_p <- buildPParamSerialisation sname_p fields
724 879273e3 Iustin Pop
  fill_decls <- fillParam sname field_pfx fields
725 879273e3 Iustin Pop
  return $ [declF, declP] ++ ser_decls_f ++ ser_decls_p ++ fill_decls
726 879273e3 Iustin Pop
727 879273e3 Iustin Pop
buildPParamSerialisation :: String -> [Field] -> Q [Dec]
728 879273e3 Iustin Pop
buildPParamSerialisation sname fields = do
729 879273e3 Iustin Pop
  let name = mkName sname
730 879273e3 Iustin Pop
  savedecls <- genSaveObject savePParamField sname fields
731 879273e3 Iustin Pop
  (loadsig, loadfn) <- genLoadObject loadPParamField sname fields
732 879273e3 Iustin Pop
  shjson <- objectShowJSON sname
733 879273e3 Iustin Pop
  rdjson <- objectReadJSON sname
734 879273e3 Iustin Pop
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
735 879273e3 Iustin Pop
                 (rdjson:shjson)
736 879273e3 Iustin Pop
  return $ savedecls ++ [loadsig, loadfn, instdecl]
737 879273e3 Iustin Pop
738 879273e3 Iustin Pop
savePParamField :: Name -> Field -> Q Exp
739 879273e3 Iustin Pop
savePParamField fvar field = do
740 879273e3 Iustin Pop
  checkNonOptDef field
741 879273e3 Iustin Pop
  let actualVal = mkName "v"
742 879273e3 Iustin Pop
  normalexpr <- saveObjectField actualVal field
743 879273e3 Iustin Pop
  -- we have to construct the block here manually, because we can't
744 879273e3 Iustin Pop
  -- splice-in-splice
745 879273e3 Iustin Pop
  return $ CaseE (VarE fvar) [ Match (ConP 'Nothing [])
746 879273e3 Iustin Pop
                                       (NormalB (ConE '[])) []
747 879273e3 Iustin Pop
                             , Match (ConP 'Just [VarP actualVal])
748 879273e3 Iustin Pop
                                       (NormalB normalexpr) []
749 879273e3 Iustin Pop
                             ]
750 879273e3 Iustin Pop
loadPParamField :: Field -> Q (Name, Stmt)
751 879273e3 Iustin Pop
loadPParamField field = do
752 879273e3 Iustin Pop
  checkNonOptDef field
753 879273e3 Iustin Pop
  let name = fieldName field
754 879273e3 Iustin Pop
      fvar = mkName name
755 879273e3 Iustin Pop
  -- these are used in all patterns below
756 879273e3 Iustin Pop
  let objvar = varNameE "o"
757 879273e3 Iustin Pop
      objfield = stringE name
758 879273e3 Iustin Pop
      loadexp = [| $(varNameE "maybeFromObj") $objvar $objfield |]
759 879273e3 Iustin Pop
  bexp <- loadFn field loadexp
760 879273e3 Iustin Pop
  return (fvar, BindS (VarP fvar) bexp)
761 879273e3 Iustin Pop
762 879273e3 Iustin Pop
-- | Builds a simple declaration of type @n_x = fromMaybe f_x p_x@.
763 879273e3 Iustin Pop
buildFromMaybe :: String -> Q Dec
764 879273e3 Iustin Pop
buildFromMaybe fname =
765 879273e3 Iustin Pop
  valD (varP (mkName $ "n_" ++ fname))
766 879273e3 Iustin Pop
         (normalB [| $(varNameE "fromMaybe")
767 879273e3 Iustin Pop
                        $(varNameE $ "f_" ++ fname)
768 879273e3 Iustin Pop
                        $(varNameE $ "p_" ++ fname) |]) []
769 879273e3 Iustin Pop
770 879273e3 Iustin Pop
fillParam :: String -> String -> [Field] -> Q [Dec]
771 879273e3 Iustin Pop
fillParam sname field_pfx fields = do
772 879273e3 Iustin Pop
  let fnames = map (\fd -> field_pfx ++ fieldRecordName fd) fields
773 879273e3 Iustin Pop
      (sname_f, sname_p) = paramTypeNames sname
774 879273e3 Iustin Pop
      oname_f = "fobj"
775 879273e3 Iustin Pop
      oname_p = "pobj"
776 879273e3 Iustin Pop
      name_f = mkName sname_f
777 879273e3 Iustin Pop
      name_p = mkName sname_p
778 879273e3 Iustin Pop
      fun_name = mkName $ "fill" ++ sname ++ "Params"
779 879273e3 Iustin Pop
      le_full = ValD (ConP name_f (map (VarP . mkName . ("f_" ++)) fnames))
780 879273e3 Iustin Pop
                (NormalB . VarE . mkName $ oname_f) []
781 879273e3 Iustin Pop
      le_part = ValD (ConP name_p (map (VarP . mkName . ("p_" ++)) fnames))
782 879273e3 Iustin Pop
                (NormalB . VarE . mkName $ oname_p) []
783 879273e3 Iustin Pop
      obj_new = foldl (\accu vname -> AppE accu (VarE vname)) (ConE name_f)
784 879273e3 Iustin Pop
                $ map (mkName . ("n_" ++)) fnames
785 879273e3 Iustin Pop
  le_new <- mapM buildFromMaybe fnames
786 879273e3 Iustin Pop
  funt <- [t| $(conT name_f) -> $(conT name_p) -> $(conT name_f) |]
787 879273e3 Iustin Pop
  let sig = SigD fun_name funt
788 879273e3 Iustin Pop
      fclause = Clause [VarP (mkName oname_f), VarP (mkName oname_p)]
789 879273e3 Iustin Pop
                (NormalB $ LetE (le_full:le_part:le_new) obj_new) []
790 879273e3 Iustin Pop
      fun = FunD fun_name [fclause]
791 879273e3 Iustin Pop
  return [sig, fun]