THH.hs 29.6 KB
Newer Older
1
{-# LANGUAGE TemplateHaskell #-}
2 3 4 5 6 7 8 9 10 11 12

{-| TemplateHaskell helper for HTools.

As TemplateHaskell require that splices be defined in a separate
module, we combine all the TemplateHaskell functionality that HTools
needs in this module (except the one for unittests).

-}

{-

13
Copyright (C) 2011, 2012 Google Inc.
14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.

-}

32
module Ganeti.THH ( declareSADT
33
                  , declareIADT
34
                  , makeJSONInstance
35
                  , genOpID
36
                  , genOpCode
37 38 39
                  , genStrOfOp
                  , genStrOfKey
                  , genLuxiOp
40 41 42 43 44 45 46 47 48 49
                  , Field
                  , simpleField
                  , defaultField
                  , optionalField
                  , renameField
                  , containerField
                  , customField
                  , timeStampFields
                  , uuidFields
                  , serialFields
Iustin Pop's avatar
Iustin Pop committed
50
                  , tagsFields
51 52 53 54
                  , buildObject
                  , buildObjectSerialisation
                  , buildParam
                  , Container
55 56
                  ) where

57
import Control.Arrow
58
import Control.Monad (liftM, liftM2)
59
import Data.Char
60
import Data.List
61
import qualified Data.Map as M
Iustin Pop's avatar
Iustin Pop committed
62
import qualified Data.Set as Set
63 64 65 66
import Language.Haskell.TH

import qualified Text.JSON as JSON

67 68
import Ganeti.HTools.JSON

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
-- * Exported types

type Container = M.Map String

-- | Serialised field data type.
data Field = Field { fieldName        :: String
                   , fieldType        :: Q Type
                   , fieldRead        :: Maybe (Q Exp)
                   , fieldShow        :: Maybe (Q Exp)
                   , fieldDefault     :: Maybe (Q Exp)
                   , fieldConstr      :: Maybe String
                   , fieldIsContainer :: Bool
                   , fieldIsOptional  :: Bool
                   }

-- | Generates a simple field.
simpleField :: String -> Q Type -> Field
simpleField fname ftype =
  Field { fieldName        = fname
        , fieldType        = ftype
        , fieldRead        = Nothing
        , fieldShow        = Nothing
        , fieldDefault     = Nothing
        , fieldConstr      = Nothing
        , fieldIsContainer = False
        , fieldIsOptional  = False
        }

-- | Sets the renamed constructor field.
renameField :: String -> Field -> Field
renameField constrName field = field { fieldConstr = Just constrName }

-- | Sets the default value on a field (makes it optional with a
-- default value).
defaultField :: Q Exp -> Field -> Field
defaultField defval field = field { fieldDefault = Just defval }

-- | Marks a field optional (turning its base type into a Maybe).
optionalField :: Field -> Field
optionalField field = field { fieldIsOptional = True }

-- | Marks a field as a container.
containerField :: Field -> Field
containerField field = field { fieldIsContainer = True }

-- | Sets custom functions on a field.
Iustin Pop's avatar
Iustin Pop committed
115 116 117 118
customField :: Name    -- ^ The name of the read function
            -> Name    -- ^ The name of the show function
            -> Field   -- ^ The original field
            -> Field   -- ^ Updated field
119
customField readfn showfn field =
Iustin Pop's avatar
Iustin Pop committed
120
  field { fieldRead = Just (varE readfn), fieldShow = Just (varE showfn) }
121 122 123 124 125

fieldRecordName :: Field -> String
fieldRecordName (Field { fieldName = name, fieldConstr = alias }) =
  maybe (camelCase name) id alias

126 127 128 129
-- | Computes the preferred variable name to use for the value of this
-- field. If the field has a specific constructor name, then we use a
-- first-letter-lowercased version of that; otherwise, we simply use
-- the field name. See also 'fieldRecordName'.
130
fieldVariable :: Field -> String
131 132 133 134
fieldVariable f =
  case (fieldConstr f) of
    Just name -> ensureLower name
    _ -> fieldName f
135 136 137 138 139 140 141 142 143 144 145 146 147 148

actualFieldType :: Field -> Q Type
actualFieldType f | fieldIsContainer f = [t| Container $t |]
                  | fieldIsOptional f  = [t| Maybe $t     |]
                  | otherwise = t
                  where t = fieldType f

checkNonOptDef :: (Monad m) => Field -> m ()
checkNonOptDef (Field { fieldIsOptional = True, fieldName = name }) =
  fail $ "Optional field " ++ name ++ " used in parameter declaration"
checkNonOptDef (Field { fieldDefault = (Just _), fieldName = name }) =
  fail $ "Default field " ++ name ++ " used in parameter declaration"
checkNonOptDef _ = return ()

149 150 151 152 153 154 155 156 157 158 159 160
-- | Produces the expression that will de-serialise a given
-- field. Since some custom parsing functions might need to use the
-- entire object, we do take and pass the object to any custom read
-- functions.
loadFn :: Field   -- ^ The field definition
       -> Q Exp   -- ^ The value of the field as existing in the JSON message
       -> Q Exp   -- ^ The entire object in JSON object format
       -> Q Exp   -- ^ Resulting expression
loadFn (Field { fieldIsContainer = True }) expr _ =
  [| $expr >>= readContainer |]
loadFn (Field { fieldRead = Just readfn }) expr o = [| $expr >>= $readfn $o |]
loadFn _ expr _ = expr
161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176

-- * Common field declarations

timeStampFields :: [Field]
timeStampFields =
    [ defaultField [| 0::Double |] $ simpleField "ctime" [t| Double |]
    , defaultField [| 0::Double |] $ simpleField "mtime" [t| Double |]
    ]

serialFields :: [Field]
serialFields =
    [ renameField  "Serial" $ simpleField "serial_no" [t| Int |] ]

uuidFields :: [Field]
uuidFields = [ simpleField "uuid" [t| String |] ]

Iustin Pop's avatar
Iustin Pop committed
177 178 179 180 181
-- | Tag field description.
tagsFields :: [Field]
tagsFields = [ defaultField [| Set.empty |] $
               simpleField "tags" [t| Set.Set String |] ]

Iustin Pop's avatar
Iustin Pop committed
182 183
-- * Helper functions

184 185 186
-- | Ensure first letter is lowercase.
--
-- Used to convert type name to function prefix, e.g. in @data Aa ->
187
-- aaToRaw@.
188 189 190 191
ensureLower :: String -> String
ensureLower [] = []
ensureLower (x:xs) = toLower x:xs

192 193 194 195 196 197 198
-- | Ensure first letter is uppercase.
--
-- Used to convert constructor name to component
ensureUpper :: String -> String
ensureUpper [] = []
ensureUpper (x:xs) = toUpper x:xs

Iustin Pop's avatar
Iustin Pop committed
199 200 201 202 203 204 205 206
-- | Helper for quoted expressions.
varNameE :: String -> Q Exp
varNameE = varE . mkName

-- | showJSON as an expression, for reuse.
showJSONE :: Q Exp
showJSONE = varNameE "showJSON"

207 208 209
-- | ToRaw function name.
toRawName :: String -> Name
toRawName = mkName . (++ "ToRaw") . ensureLower
210

211 212 213
-- | FromRaw function name.
fromRawName :: String -> Name
fromRawName = mkName . (++ "FromRaw") . ensureLower
214

215 216 217
-- | Converts a name to it's varE/litE representations.
--
reprE :: Either String Name -> Q Exp
Iustin Pop's avatar
Iustin Pop committed
218 219
reprE = either stringE varE

220 221 222 223 224 225 226 227
-- | Smarter function application.
--
-- This does simply f x, except that if is 'id', it will skip it, in
-- order to generate more readable code when using -ddump-splices.
appFn :: Exp -> Exp -> Exp
appFn f x | f == VarE 'id = x
          | otherwise = AppE f x

228
-- | Container loader
229 230 231 232 233 234
readContainer :: (Monad m, JSON.JSON a) =>
                 JSON.JSObject JSON.JSValue -> m (Container a)
readContainer obj = do
  let kjvlist = JSON.fromJSObject obj
  kalist <- mapM (\(k, v) -> fromKeyValue k v >>= \a -> return (k, a)) kjvlist
  return $ M.fromList kalist
235 236 237 238 239

-- | Container dumper
showContainer :: (JSON.JSON a) => Container a -> JSON.JSValue
showContainer = JSON.makeObj . map (second JSON.showJSON) . M.toList

240
-- * Template code for simple raw type-equivalent ADTs
241

242 243 244 245 246
-- | Generates a data type declaration.
--
-- The type will have a fixed list of instances.
strADTDecl :: Name -> [String] -> Dec
strADTDecl name constructors =
247 248 249
  DataD [] name []
          (map (flip NormalC [] . mkName) constructors)
          [''Show, ''Read, ''Eq, ''Enum, ''Bounded, ''Ord]
250

251
-- | Generates a toRaw function.
252 253 254 255
--
-- This generates a simple function of the form:
--
-- @
256 257 258
-- nameToRaw :: Name -> /traw/
-- nameToRaw Cons1 = var1
-- nameToRaw Cons2 = \"value2\"
259
-- @
260 261
genToRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec]
genToRaw traw fname tname constructors = do
262
  let sigt = AppT (AppT ArrowT (ConT tname)) (ConT traw)
263
  -- the body clauses, matching on the constructor and returning the
264
  -- raw value
265
  clauses <- mapM  (\(c, v) -> clause [recP (mkName c) []]
266
                             (normalB (reprE v)) []) constructors
267 268
  return [SigD fname sigt, FunD fname clauses]

269
-- | Generates a fromRaw function.
270 271
--
-- The function generated is monadic and can fail parsing the
272
-- raw value. It is of the form:
273 274
--
-- @
275 276 277 278
-- nameFromRaw :: (Monad m) => /traw/ -> m Name
-- nameFromRaw s | s == var1       = Cons1
--               | s == \"value2\" = Cons2
--               | otherwise = fail /.../
279
-- @
280 281
genFromRaw :: Name -> Name -> Name -> [(String, Name)] -> Q [Dec]
genFromRaw traw fname tname constructors = do
282
  -- signature of form (Monad m) => String -> m $name
283
  sigt <- [t| (Monad m) => $(conT traw) -> m $(conT tname) |]
284 285 286 287 288 289 290 291 292 293 294 295 296
  -- clauses for a guarded pattern
  let varp = mkName "s"
      varpe = varE varp
  clauses <- mapM (\(c, v) -> do
                     -- the clause match condition
                     g <- normalG [| $varpe == $(varE v) |]
                     -- the clause result
                     r <- [| return $(conE (mkName c)) |]
                     return (g, r)) constructors
  -- the otherwise clause (fallback)
  oth_clause <- do
    g <- normalG [| otherwise |]
    r <- [|fail ("Invalid string value for type " ++
297
                 $(litE (stringL (nameBase tname))) ++ ": " ++ show $varpe) |]
298 299 300 301 302
    return (g, r)
  let fun = FunD fname [Clause [VarP varp]
                        (GuardedB (clauses++[oth_clause])) []]
  return [SigD fname sigt, fun]

303
-- | Generates a data type from a given raw format.
304 305 306 307 308 309 310 311 312
--
-- The format is expected to multiline. The first line contains the
-- type name, and the rest of the lines must contain two words: the
-- constructor name and then the string representation of the
-- respective constructor.
--
-- The function will generate the data type declaration, and then two
-- functions:
--
313
-- * /name/ToRaw, which converts the type to a raw type
314
--
315
-- * /name/FromRaw, which (monadically) converts from a raw type to the type
316 317 318
--
-- Note that this is basically just a custom show/read instance,
-- nothing else.
319 320
declareADT :: Name -> String -> [(String, Name)] -> Q [Dec]
declareADT traw sname cons = do
321 322
  let name = mkName sname
      ddecl = strADTDecl name (map fst cons)
323
      -- process cons in the format expected by genToRaw
324
      cons' = map (\(a, b) -> (a, Right b)) cons
325 326 327
  toraw <- genToRaw traw (toRawName sname) name cons'
  fromraw <- genFromRaw traw (fromRawName sname) name cons
  return $ ddecl:toraw ++ fromraw
328

329 330 331 332 333
declareIADT :: String -> [(String, Name)] -> Q [Dec]
declareIADT = declareADT ''Int

declareSADT :: String -> [(String, Name)] -> Q [Dec]
declareSADT = declareADT ''String
334 335 336 337 338 339

-- | Creates the showJSON member of a JSON instance declaration.
--
-- This will create what is the equivalent of:
--
-- @
340
-- showJSON = showJSON . /name/ToRaw
341 342 343
-- @
--
-- in an instance JSON /name/ declaration
344 345 346 347
genShowJSON :: String -> Q Dec
genShowJSON name = do
  body <- [| JSON.showJSON . $(varE (toRawName name)) |]
  return $ FunD (mkName "showJSON") [Clause [] (NormalB body) []]
348 349 350 351 352 353 354

-- | Creates the readJSON member of a JSON instance declaration.
--
-- This will create what is the equivalent of:
--
-- @
-- readJSON s = case readJSON s of
355
--                Ok s' -> /name/FromRaw s'
356 357 358 359 360 361 362 363
--                Error e -> Error /description/
-- @
--
-- in an instance JSON /name/ declaration
genReadJSON :: String -> Q Dec
genReadJSON name = do
  let s = mkName "s"
  body <- [| case JSON.readJSON $(varE s) of
364
               JSON.Ok s' -> $(varE (fromRawName name)) s'
365
               JSON.Error e ->
366
                   JSON.Error $ "Can't parse raw value for type " ++
367 368
                           $(stringE name) ++ ": " ++ e ++ " from " ++
                           show $(varE s)
369 370 371 372 373
           |]
  return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []]

-- | Generates a JSON instance for a given type.
--
374
-- This assumes that the /name/ToRaw and /name/FromRaw functions
375 376 377 378 379 380
-- have been defined as by the 'declareSADT' function.
makeJSONInstance :: Name -> Q [Dec]
makeJSONInstance name = do
  let base = nameBase name
  showJ <- genShowJSON base
  readJ <- genReadJSON base
381
  return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) [readJ,showJ]]
382

Iustin Pop's avatar
Iustin Pop committed
383 384
-- * Template code for opcodes

385 386 387 388 389
-- | Transforms a CamelCase string into an_underscore_based_one.
deCamelCase :: String -> String
deCamelCase =
    intercalate "_" . map (map toUpper) . groupBy (\_ b -> not $ isUpper b)

390 391 392 393 394
-- | Transform an underscore_name into a CamelCase one.
camelCase :: String -> String
camelCase = concatMap (ensureUpper . drop 1) .
            groupBy (\_ b -> b /= '_') . ('_':)

395
-- | Computes the name of a given constructor.
396 397 398 399 400
constructorName :: Con -> Q Name
constructorName (NormalC name _) = return name
constructorName (RecC name _)    = return name
constructorName x                = fail $ "Unhandled constructor " ++ show x

401
-- | Builds the generic constructor-to-string function.
402 403 404 405
--
-- This generates a simple function of the following form:
--
-- @
406 407
-- fname (ConStructorOne {}) = trans_fun("ConStructorOne")
-- fname (ConStructorTwo {}) = trans_fun("ConStructorTwo")
408 409 410
-- @
--
-- This builds a custom list of name/string pairs and then uses
411
-- 'genToRaw' to actually generate the function
412 413
genConstrToStr :: (String -> String) -> Name -> String -> Q [Dec]
genConstrToStr trans_fun name fname = do
414 415
  TyConI (DataD _ _ _ cons _) <- reify name
  cnames <- mapM (liftM nameBase . constructorName) cons
416
  let svalues = map (Left . trans_fun) cnames
417
  genToRaw ''String (mkName fname) name $ zip cnames svalues
418

419 420 421
-- | Constructor-to-string for OpCode.
genOpID :: Name -> String -> Q [Dec]
genOpID = genConstrToStr deCamelCase
422

423
-- | OpCode parameter (field) type.
424 425 426 427 428 429 430 431 432
type OpParam = (String, Q Type, Q Exp)

-- | Generates the OpCode data type.
--
-- This takes an opcode logical definition, and builds both the
-- datatype and the JSON serialisation out of it. We can't use a
-- generic serialisation since we need to be compatible with Ganeti's
-- own, so we have a few quirks to work around.
genOpCode :: String                -- ^ Type name to use
433
          -> [(String, [Field])]   -- ^ Constructor name and parameters
434 435 436 437
          -> Q [Dec]
genOpCode name cons = do
  decl_d <- mapM (\(cname, fields) -> do
                    -- we only need the type of the field, without Q
438 439 440
                    fields' <- mapM actualFieldType fields
                    let fields'' = zip (repeat NotStrict) fields'
                    return $ NormalC (mkName cname) fields'')
441 442 443 444 445 446 447
            cons
  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq]

  (savesig, savefn) <- genSaveOpCode cons
  (loadsig, loadfn) <- genLoadOpCode cons
  return [declD, loadsig, loadfn, savesig, savefn]

448
-- | Checks whether a given parameter is options.
449 450 451 452 453 454 455 456 457 458
--
-- This requires that it's a 'Maybe'.
isOptional :: Type -> Bool
isOptional (AppT (ConT dt) _) | dt == ''Maybe = True
isOptional _ = False

-- | Generates the \"save\" clause for an entire opcode constructor.
--
-- This matches the opcode with variables named the same as the
-- constructor fields (just so that the spliced in code looks nicer),
459
-- and passes those name plus the parameter definition to 'saveObjectField'.
460
saveConstructor :: String    -- ^ The constructor name
461
                -> [Field]   -- ^ The parameter definitions for this
462 463 464 465
                             -- constructor
                -> Q Clause  -- ^ Resulting clause
saveConstructor sname fields = do
  let cname = mkName sname
466
  let fnames = map (mkName . fieldVariable) fields
467
  let pat = conP cname (map varP fnames)
468
  let felems = map (uncurry saveObjectField) (zip fnames fields)
469
      -- now build the OP_ID serialisation
Iustin Pop's avatar
Iustin Pop committed
470
      opid = [| [( $(stringE "OP_ID"),
471
                   JSON.showJSON $(stringE . deCamelCase $ sname) )] |]
472 473
      flist = listE (opid:felems)
      -- and finally convert all this to a json object
Iustin Pop's avatar
Iustin Pop committed
474
      flist' = [| $(varNameE "makeObj") (concat $flist) |]
475 476 477 478 479 480
  clause [pat] (normalB flist') []

-- | Generates the main save opcode function.
--
-- This builds a per-constructor match clause that contains the
-- respective constructor-serialisation code.
481
genSaveOpCode :: [(String, [Field])] -> Q (Dec, Dec)
482 483 484 485 486 487
genSaveOpCode opdefs = do
  cclauses <- mapM (uncurry saveConstructor) opdefs
  let fname = mkName "saveOpCode"
  sigt <- [t| $(conT (mkName "OpCode")) -> JSON.JSValue |]
  return $ (SigD fname sigt, FunD fname cclauses)

488
loadConstructor :: String -> [Field] -> Q Exp
489 490
loadConstructor sname fields = do
  let name = mkName sname
491
  fbinds <- mapM loadObjectField fields
492 493 494 495 496
  let (fnames, fstmts) = unzip fbinds
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
      fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
  return $ DoE fstmts'

497
genLoadOpCode :: [(String, [Field])] -> Q (Dec, Dec)
498 499 500 501 502 503 504
genLoadOpCode opdefs = do
  let fname = mkName "loadOpCode"
      arg1 = mkName "v"
      objname = mkName "o"
      opid = mkName "op_id"
  st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
                                 (JSON.readJSON $(varE arg1)) |]
Iustin Pop's avatar
Iustin Pop committed
505 506
  st2 <- bindS (varP opid) [| $(varNameE "fromObj")
                              $(varE objname) $(stringE "OP_ID") |]
507 508 509 510 511 512 513 514 515 516 517 518 519
  -- the match results (per-constructor blocks)
  mexps <- mapM (uncurry loadConstructor) opdefs
  fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |]
  let mpats = map (\(me, c) ->
                       let mp = LitP . StringL . deCamelCase . fst $ c
                       in Match mp (NormalB me) []
                  ) $ zip mexps opdefs
      defmatch = Match WildP (NormalB fails) []
      cst = NoBindS $ CaseE (VarE opid) $ mpats++[defmatch]
      body = DoE [st1, st2, cst]
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT (mkName "OpCode")) |]
  return $ (SigD fname sigt, FunD fname [Clause [VarP arg1] (NormalB body) []])

520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548
-- * Template code for luxi

-- | Constructor-to-string for LuxiOp.
genStrOfOp :: Name -> String -> Q [Dec]
genStrOfOp = genConstrToStr id

-- | Constructor-to-string for MsgKeys.
genStrOfKey :: Name -> String -> Q [Dec]
genStrOfKey = genConstrToStr ensureLower

-- | LuxiOp parameter type.
type LuxiParam = (String, Q Type, Q Exp)

-- | Generates the LuxiOp data type.
--
-- This takes a Luxi operation definition and builds both the
-- datatype and the function trnasforming the arguments to JSON.
-- We can't use anything less generic, because the way different
-- operations are serialized differs on both parameter- and top-level.
--
-- There are three things to be defined for each parameter:
--
-- * name
--
-- * type
--
-- * operation; this is the operation performed on the parameter before
--   serialization
--
549
genLuxiOp :: String -> [(String, [LuxiParam])] -> Q [Dec]
550
genLuxiOp name cons = do
551
  decl_d <- mapM (\(cname, fields) -> do
552 553 554 555 556
                    fields' <- mapM (\(_, qt, _) ->
                                         qt >>= \t -> return (NotStrict, t))
                               fields
                    return $ NormalC (mkName cname) fields')
            cons
557
  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq]
558
  (savesig, savefn) <- genSaveLuxiOp cons
Iustin Pop's avatar
Iustin Pop committed
559 560 561 562
  req_defs <- declareSADT "LuxiReq" .
              map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $
                  cons
  return $ [declD, savesig, savefn] ++ req_defs
563

564
-- | Generates the \"save\" expression for a single luxi parameter.
565 566 567
saveLuxiField :: Name -> LuxiParam -> Q Exp
saveLuxiField fvar (_, qt, fn) =
    [| JSON.showJSON ( $(liftM2 appFn fn $ varE fvar) ) |]
568

569
-- | Generates the \"save\" clause for entire LuxiOp constructor.
570 571
saveLuxiConstructor :: (String, [LuxiParam]) -> Q Clause
saveLuxiConstructor (sname, fields) = do
572 573 574
  let cname = mkName sname
      fnames = map (\(nm, _, _) -> mkName nm) fields
      pat = conP cname (map varP fnames)
575 576 577 578
      flist = map (uncurry saveLuxiField) (zip fnames fields)
      finval = if null flist
               then [| JSON.showJSON ()    |]
               else [| JSON.showJSON $(listE flist) |]
579
  clause [pat] (normalB finval) []
580 581

-- | Generates the main save LuxiOp function.
582
genSaveLuxiOp :: [(String, [LuxiParam])]-> Q (Dec, Dec)
583 584 585 586 587
genSaveLuxiOp opdefs = do
  sigt <- [t| $(conT (mkName "LuxiOp")) -> JSON.JSValue |]
  let fname = mkName "opToArgs"
  cclauses <- mapM saveLuxiConstructor opdefs
  return $ (SigD fname sigt, FunD fname cclauses)
588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603

-- * "Objects" functionality

-- | Extract the field's declaration from a Field structure.
fieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
fieldTypeInfo field_pfx fd = do
  t <- actualFieldType fd
  let n = mkName . (field_pfx ++) . fieldRecordName $ fd
  return (n, NotStrict, t)

-- | Build an object declaration.
buildObject :: String -> String -> [Field] -> Q [Dec]
buildObject sname field_pfx fields = do
  let name = mkName sname
  fields_d <- mapM (fieldTypeInfo field_pfx) fields
  let decl_d = RecC name fields_d
604
  let declD = DataD [] name [] [decl_d] [''Show, ''Read, ''Eq]
605 606 607 608 609 610 611 612 613 614 615
  ser_decls <- buildObjectSerialisation sname fields
  return $ declD:ser_decls

buildObjectSerialisation :: String -> [Field] -> Q [Dec]
buildObjectSerialisation sname fields = do
  let name = mkName sname
  savedecls <- genSaveObject saveObjectField sname fields
  (loadsig, loadfn) <- genLoadObject loadObjectField sname fields
  shjson <- objectShowJSON sname
  rdjson <- objectReadJSON sname
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
616
                 [rdjson, shjson]
617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641
  return $ savedecls ++ [loadsig, loadfn, instdecl]

genSaveObject :: (Name -> Field -> Q Exp)
              -> String -> [Field] -> Q [Dec]
genSaveObject save_fn sname fields = do
  let name = mkName sname
  let fnames = map (mkName . fieldVariable) fields
  let pat = conP name (map varP fnames)
  let tdname = mkName ("toDict" ++ sname)
  tdsigt <- [t| $(conT name) -> [(String, JSON.JSValue)] |]

  let felems = map (uncurry save_fn) (zip fnames fields)
      flist = listE felems
      -- and finally convert all this to a json object
      tdlist = [| concat $flist |]
      iname = mkName "i"
  tclause <- clause [pat] (normalB tdlist) []
  cclause <- [| $(varNameE "makeObj") . $(varE tdname) |]
  let fname = mkName ("save" ++ sname)
  sigt <- [t| $(conT name) -> JSON.JSValue |]
  return [SigD tdname tdsigt, FunD tdname [tclause],
          SigD fname sigt, ValD (VarP fname) (NormalB cclause) []]

saveObjectField :: Name -> Field -> Q Exp
saveObjectField fvar field
642
  | isContainer = [| [( $nameE , JSON.showJSON . showContainer $ $fvarE)] |]
643 644
  | fisOptional = [| case $(varE fvar) of
                      Nothing -> []
645
                      Just v -> [( $nameE, JSON.showJSON v)]
646 647
                  |]
  | otherwise = case fieldShow field of
648
      Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |]
649 650 651
      Just fn -> [| let (actual, extra) = $fn $fvarE
                    in extra ++ [( $nameE, JSON.showJSON actual)]
                  |]
652 653 654 655 656
  where isContainer = fieldIsContainer field
        fisOptional  = fieldIsOptional field
        nameE = stringE (fieldName field)
        fvarE = varE fvar

657 658 659 660
objectShowJSON :: String -> Q Dec
objectShowJSON name = do
  body <- [| JSON.showJSON . $(varE . mkName $ "save" ++ name) |]
  return $ FunD (mkName "showJSON") [Clause [] (NormalB body) []]
661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694

genLoadObject :: (Field -> Q (Name, Stmt))
              -> String -> [Field] -> Q (Dec, Dec)
genLoadObject load_fn sname fields = do
  let name = mkName sname
      funname = mkName $ "load" ++ sname
      arg1 = mkName "v"
      objname = mkName "o"
      opid = mkName "op_id"
  st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
                                 (JSON.readJSON $(varE arg1)) |]
  fbinds <- mapM load_fn fields
  let (fnames, fstmts) = unzip fbinds
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
      fstmts' = st1:fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT name) |]
  return $ (SigD funname sigt,
            FunD funname [Clause [VarP arg1] (NormalB (DoE fstmts')) []])

loadObjectField :: Field -> Q (Name, Stmt)
loadObjectField field = do
  let name = fieldVariable field
      fvar = mkName name
  -- these are used in all patterns below
  let objvar = varNameE "o"
      objfield = stringE (fieldName field)
      loadexp =
        if fieldIsOptional field
          then [| $(varNameE "maybeFromObj") $objvar $objfield |]
          else case fieldDefault field of
                 Just defv ->
                   [| $(varNameE "fromObjWithDefault") $objvar
                      $objfield $defv |]
                 Nothing -> [| $(varNameE "fromObj") $objvar $objfield |]
695
  bexp <- loadFn field loadexp objvar
696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740

  return (fvar, BindS (VarP fvar) bexp)

objectReadJSON :: String -> Q Dec
objectReadJSON name = do
  let s = mkName "s"
  body <- [| case JSON.readJSON $(varE s) of
               JSON.Ok s' -> $(varE .mkName $ "load" ++ name) s'
               JSON.Error e ->
                 JSON.Error $ "Can't parse value for type " ++
                       $(stringE name) ++ ": " ++ e
           |]
  return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []]

-- * Inheritable parameter tables implementation

-- | Compute parameter type names.
paramTypeNames :: String -> (String, String)
paramTypeNames root = ("Filled"  ++ root ++ "Params",
                       "Partial" ++ root ++ "Params")

-- | Compute information about the type of a parameter field.
paramFieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
paramFieldTypeInfo field_pfx fd = do
  t <- actualFieldType fd
  let n = mkName . (++ "P") . (field_pfx ++) .
          fieldRecordName $ fd
  return (n, NotStrict, AppT (ConT ''Maybe) t)

-- | Build a parameter declaration.
--
-- This function builds two different data structures: a /filled/ one,
-- in which all fields are required, and a /partial/ one, in which all
-- fields are optional. Due to the current record syntax issues, the
-- fields need to be named differrently for the two structures, so the
-- partial ones get a /P/ suffix.
buildParam :: String -> String -> [Field] -> Q [Dec]
buildParam sname field_pfx fields = do
  let (sname_f, sname_p) = paramTypeNames sname
      name_f = mkName sname_f
      name_p = mkName sname_p
  fields_f <- mapM (fieldTypeInfo field_pfx) fields
  fields_p <- mapM (paramFieldTypeInfo field_pfx) fields
  let decl_f = RecC name_f fields_f
      decl_p = RecC name_p fields_p
741 742
  let declF = DataD [] name_f [] [decl_f] [''Show, ''Read, ''Eq]
      declP = DataD [] name_p [] [decl_p] [''Show, ''Read, ''Eq]
743 744 745 746 747 748 749 750 751 752 753 754 755
  ser_decls_f <- buildObjectSerialisation sname_f fields
  ser_decls_p <- buildPParamSerialisation sname_p fields
  fill_decls <- fillParam sname field_pfx fields
  return $ [declF, declP] ++ ser_decls_f ++ ser_decls_p ++ fill_decls

buildPParamSerialisation :: String -> [Field] -> Q [Dec]
buildPParamSerialisation sname fields = do
  let name = mkName sname
  savedecls <- genSaveObject savePParamField sname fields
  (loadsig, loadfn) <- genLoadObject loadPParamField sname fields
  shjson <- objectShowJSON sname
  rdjson <- objectReadJSON sname
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
756
                 [rdjson, shjson]
757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779
  return $ savedecls ++ [loadsig, loadfn, instdecl]

savePParamField :: Name -> Field -> Q Exp
savePParamField fvar field = do
  checkNonOptDef field
  let actualVal = mkName "v"
  normalexpr <- saveObjectField actualVal field
  -- we have to construct the block here manually, because we can't
  -- splice-in-splice
  return $ CaseE (VarE fvar) [ Match (ConP 'Nothing [])
                                       (NormalB (ConE '[])) []
                             , Match (ConP 'Just [VarP actualVal])
                                       (NormalB normalexpr) []
                             ]
loadPParamField :: Field -> Q (Name, Stmt)
loadPParamField field = do
  checkNonOptDef field
  let name = fieldName field
      fvar = mkName name
  -- these are used in all patterns below
  let objvar = varNameE "o"
      objfield = stringE name
      loadexp = [| $(varNameE "maybeFromObj") $objvar $objfield |]
780
  bexp <- loadFn field loadexp objvar
781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812
  return (fvar, BindS (VarP fvar) bexp)

-- | Builds a simple declaration of type @n_x = fromMaybe f_x p_x@.
buildFromMaybe :: String -> Q Dec
buildFromMaybe fname =
  valD (varP (mkName $ "n_" ++ fname))
         (normalB [| $(varNameE "fromMaybe")
                        $(varNameE $ "f_" ++ fname)
                        $(varNameE $ "p_" ++ fname) |]) []

fillParam :: String -> String -> [Field] -> Q [Dec]
fillParam sname field_pfx fields = do
  let fnames = map (\fd -> field_pfx ++ fieldRecordName fd) fields
      (sname_f, sname_p) = paramTypeNames sname
      oname_f = "fobj"
      oname_p = "pobj"
      name_f = mkName sname_f
      name_p = mkName sname_p
      fun_name = mkName $ "fill" ++ sname ++ "Params"
      le_full = ValD (ConP name_f (map (VarP . mkName . ("f_" ++)) fnames))
                (NormalB . VarE . mkName $ oname_f) []
      le_part = ValD (ConP name_p (map (VarP . mkName . ("p_" ++)) fnames))
                (NormalB . VarE . mkName $ oname_p) []
      obj_new = foldl (\accu vname -> AppE accu (VarE vname)) (ConE name_f)
                $ map (mkName . ("n_" ++)) fnames
  le_new <- mapM buildFromMaybe fnames
  funt <- [t| $(conT name_f) -> $(conT name_p) -> $(conT name_f) |]
  let sig = SigD fun_name funt
      fclause = Clause [VarP (mkName oname_f), VarP (mkName oname_p)]
                (NormalB $ LetE (le_full:le_part:le_new) obj_new) []
      fun = FunD fun_name [fclause]
  return [sig, fun]