Revision a1505857

b/htools/Ganeti/OpCodes.hs
54 54
-- actually use in the htools codebase.
55 55
$(genOpCode "OpCode"
56 56
  [ ("OpTestDelay",
57
     [ ("duration",  [t| Double   |], noDefault)
58
     , ("on_master", [t| Bool     |], noDefault)
59
     , ("on_nodes",  [t| [String] |], noDefault)
57
     [ simpleField "duration"  [t| Double   |]
58
     , simpleField "on_master" [t| Bool     |]
59
     , simpleField "on_nodes"  [t| [String] |]
60 60
     ])
61 61
  , ("OpInstanceReplaceDisks",
62
     [ ("instance_name", [t| String           |], noDefault)
63
     , ("remote_node",   [t| Maybe String     |], noDefault)
64
     , ("mode",          [t| ReplaceDisksMode |], noDefault)
65
     , ("disks",         [t| [Int]            |], noDefault)
66
     , ("iallocator",    [t| Maybe String     |], noDefault)
62
     [ simpleField "instance_name" [t| String |]
63
     , optionalField $ simpleField "remote_node" [t| String |]
64
     , simpleField "mode"  [t| ReplaceDisksMode |]
65
     , simpleField "disks" [t| [Int] |]
66
     , optionalField $ simpleField "iallocator" [t| String |]
67 67
     ])
68 68
  , ("OpInstanceFailover",
69
     [ ("instance_name",      [t| String       |], noDefault)
70
     , ("ignore_consistency", [t| Bool         |], noDefault)
71
     , ("target_node",        [t| Maybe String |], noDefault)
69
     [ simpleField "instance_name"      [t| String |]
70
     , simpleField "ignore_consistency" [t| Bool   |]
71
     , optionalField $ simpleField "target_node" [t| String |]
72 72
     ])
73 73
  , ("OpInstanceMigrate",
74
     [ ("instance_name",  [t| String       |], noDefault)
75
     , ("live",           [t| Bool         |], noDefault)
76
     , ("cleanup",        [t| Bool         |], noDefault)
77
     , ("allow_failover", [t| Bool         |], [| Just False |])
78
     , ("target_node",    [t| Maybe String |], noDefault)
74
     [ simpleField "instance_name"  [t| String |]
75
     , simpleField "live"           [t| Bool   |]
76
     , simpleField "cleanup"        [t| Bool   |]
77
     , defaultField [| False |] $ simpleField "allow_failover" [t| Bool |]
78
     , optionalField $ simpleField "target_node" [t| String |]
79 79
     ])
80 80
  ])
81 81

  
b/htools/Ganeti/THH.hs
1
{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
1
{-# LANGUAGE TemplateHaskell #-}
2 2

  
3 3
{-| TemplateHaskell helper for HTools.
4 4

  
......
34 34
                  , makeJSONInstance
35 35
                  , genOpID
36 36
                  , genOpCode
37
                  , noDefault
38 37
                  , genStrOfOp
39 38
                  , genStrOfKey
40 39
                  , genLuxiOp
......
119 118
fieldRecordName (Field { fieldName = name, fieldConstr = alias }) =
120 119
  maybe (camelCase name) id alias
121 120

  
121
-- | Computes the preferred variable name to use for the value of this
122
-- field. If the field has a specific constructor name, then we use a
123
-- first-letter-lowercased version of that; otherwise, we simply use
124
-- the field name. See also 'fieldRecordName'.
122 125
fieldVariable :: Field -> String
123
fieldVariable = map toLower . fieldRecordName
126
fieldVariable f =
127
  case (fieldConstr f) of
128
    Just name -> ensureLower name
129
    _ -> fieldName f
124 130

  
125 131
actualFieldType :: Field -> Q Type
126 132
actualFieldType f | fieldIsContainer f = [t| Container $t |]
......
408 414
-- datatype and the JSON serialisation out of it. We can't use a
409 415
-- generic serialisation since we need to be compatible with Ganeti's
410 416
-- own, so we have a few quirks to work around.
411
--
412
-- There are three things to be defined for each parameter:
413
--
414
-- * name
415
--
416
-- * type; if this is 'Maybe', will only be serialised if it's a
417
--   'Just' value
418
--
419
-- * default; if missing, won't raise an exception, but will instead
420
--   use the default
421
--
422 417
genOpCode :: String                -- ^ Type name to use
423
          -> [(String, [OpParam])] -- ^ Constructor name and parameters
418
          -> [(String, [Field])]   -- ^ Constructor name and parameters
424 419
          -> Q [Dec]
425 420
genOpCode name cons = do
426 421
  decl_d <- mapM (\(cname, fields) -> do
427 422
                    -- we only need the type of the field, without Q
428
                    fields' <- mapM (\(_, qt, _) ->
429
                                         qt >>= \t -> return (NotStrict, t))
430
                               fields
431
                    return $ NormalC (mkName cname) fields')
423
                    fields' <- mapM actualFieldType fields
424
                    let fields'' = zip (repeat NotStrict) fields'
425
                    return $ NormalC (mkName cname) fields'')
432 426
            cons
433 427
  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq]
434 428

  
......
443 437
isOptional (AppT (ConT dt) _) | dt == ''Maybe = True
444 438
isOptional _ = False
445 439

  
446
-- | Generates the \"save\" expression for a single opcode parameter.
447
--
448
-- There is only one special handling mode: if the parameter is of
449
-- 'Maybe' type, then we only save it if it's a 'Just' value,
450
-- otherwise we skip it.
451
saveField :: Name    -- ^ The name of variable that contains the value
452
          -> OpParam -- ^ Parameter definition
453
          -> Q Exp
454
saveField fvar (fname, qt, _) = do
455
  t <- qt
456
  let fnexp = stringE fname
457
      fvare = varE fvar
458
  (if isOptional t
459
   then [| case $fvare of
460
             Just v' -> [( $fnexp, $showJSONE v')]
461
             Nothing -> []
462
         |]
463
   else [| [( $fnexp, $showJSONE $fvare )] |])
464

  
465 440
-- | Generates the \"save\" clause for an entire opcode constructor.
466 441
--
467 442
-- This matches the opcode with variables named the same as the
468 443
-- constructor fields (just so that the spliced in code looks nicer),
469
-- and passes those name plus the parameter definition to 'saveField'.
444
-- and passes those name plus the parameter definition to 'saveObjectField'.
470 445
saveConstructor :: String    -- ^ The constructor name
471
                -> [OpParam] -- ^ The parameter definitions for this
446
                -> [Field]   -- ^ The parameter definitions for this
472 447
                             -- constructor
473 448
                -> Q Clause  -- ^ Resulting clause
474 449
saveConstructor sname fields = do
475 450
  let cname = mkName sname
476
  let fnames = map (\(n, _, _) -> mkName n) fields
451
  let fnames = map (mkName . fieldVariable) fields
477 452
  let pat = conP cname (map varP fnames)
478
  let felems = map (uncurry saveField) (zip fnames fields)
453
  let felems = map (uncurry saveObjectField) (zip fnames fields)
479 454
      -- now build the OP_ID serialisation
480 455
      opid = [| [( $(stringE "OP_ID"),
481 456
                   $showJSONE $(stringE . deCamelCase $ sname) )] |]
......
488 463
--
489 464
-- This builds a per-constructor match clause that contains the
490 465
-- respective constructor-serialisation code.
491
genSaveOpCode :: [(String, [OpParam])] -> Q (Dec, Dec)
466
genSaveOpCode :: [(String, [Field])] -> Q (Dec, Dec)
492 467
genSaveOpCode opdefs = do
493 468
  cclauses <- mapM (uncurry saveConstructor) opdefs
494 469
  let fname = mkName "saveOpCode"
495 470
  sigt <- [t| $(conT (mkName "OpCode")) -> JSON.JSValue |]
496 471
  return $ (SigD fname sigt, FunD fname cclauses)
497 472

  
498
-- | Generates the \"load\" field for a single parameter.
499
--
500
-- There is custom handling, depending on how the parameter is
501
-- specified. For a 'Maybe' type parameter, we allow that it is not
502
-- present (via 'Utils.maybeFromObj'). Otherwise, if there is a
503
-- default value, we allow the parameter to be abset, and finally if
504
-- there is no default value, we require its presence.
505
loadField :: OpParam -> Q (Name, Stmt)
506
loadField (fname, qt, qdefa) = do
507
  let fvar = mkName fname
508
  t <- qt
509
  defa <- qdefa
510
  -- these are used in all patterns below
511
  let objvar = varNameE "o"
512
      objfield = stringE fname
513
  bexp <- if isOptional t
514
          then [| $((varNameE "maybeFromObj")) $objvar $objfield |]
515
          else case defa of
516
                 AppE (ConE dt) defval | dt == 'Just ->
517
                   -- but has a default value
518
                   [| $(varNameE "fromObjWithDefault")
519
                      $objvar $objfield $(return defval) |]
520
                 ConE dt | dt == 'Nothing ->
521
                     [| $(varNameE "fromObj") $objvar $objfield |]
522
                 s -> fail $ "Invalid default value " ++ show s ++
523
                      ", expecting either 'Nothing' or a 'Just defval'"
524
  return (fvar, BindS (VarP fvar) bexp)
525

  
526
loadConstructor :: String -> [OpParam] -> Q Exp
473
loadConstructor :: String -> [Field] -> Q Exp
527 474
loadConstructor sname fields = do
528 475
  let name = mkName sname
529
  fbinds <- mapM loadField fields
476
  fbinds <- mapM loadObjectField fields
530 477
  let (fnames, fstmts) = unzip fbinds
531 478
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
532 479
      fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
533 480
  return $ DoE fstmts'
534 481

  
535
genLoadOpCode :: [(String, [OpParam])] -> Q (Dec, Dec)
482
genLoadOpCode :: [(String, [Field])] -> Q (Dec, Dec)
536 483
genLoadOpCode opdefs = do
537 484
  let fname = mkName "loadOpCode"
538 485
      arg1 = mkName "v"
......
555 502
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT (mkName "OpCode")) |]
556 503
  return $ (SigD fname sigt, FunD fname [Clause [VarP arg1] (NormalB body) []])
557 504

  
558
-- | No default type.
559
noDefault :: Q Exp
560
noDefault = conE 'Nothing
561

  
562 505
-- * Template code for luxi
563 506

  
564 507
-- | Constructor-to-string for LuxiOp.

Also available in: Unified diff