THH.hs 46 KB
Newer Older
Jose A. Lopes's avatar
Jose A. Lopes committed
1
{-# LANGUAGE ExistentialQuantification, TemplateHaskell #-}
2

3
{-| TemplateHaskell helper for Ganeti Haskell code.
4 5 6 7 8 9 10 11 12

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
                  , deCamelCase
36
                  , genOpID
37
                  , genAllConstr
38
                  , genAllOpIDs
Jose A. Lopes's avatar
Jose A. Lopes committed
39 40 41
                  , PyValue(..)
                  , PyValueEx(..)
                  , OpCodeDescriptor
42
                  , genOpCode
43 44 45
                  , genStrOfOp
                  , genStrOfKey
                  , genLuxiOp
Jose A. Lopes's avatar
Jose A. Lopes committed
46
                  , Field (..)
47
                  , simpleField
Jose A. Lopes's avatar
Jose A. Lopes committed
48
                  , withDoc
49 50
                  , defaultField
                  , optionalField
51
                  , optionalNullSerField
52 53 54 55 56
                  , renameField
                  , customField
                  , timeStampFields
                  , uuidFields
                  , serialFields
Iustin Pop's avatar
Iustin Pop committed
57
                  , tagsFields
58
                  , TagSet
59 60 61
                  , buildObject
                  , buildObjectSerialisation
                  , buildParam
62
                  , DictObject(..)
63 64
                  , genException
                  , excErrMsg
65 66
                  ) where

67
import Control.Monad (liftM)
68
import Data.Char
69
import Data.List
Iustin Pop's avatar
Iustin Pop committed
70
import qualified Data.Set as Set
71 72 73
import Language.Haskell.TH

import qualified Text.JSON as JSON
74
import Text.JSON.Pretty (pp_value)
75

76 77
import Ganeti.JSON

Jose A. Lopes's avatar
Jose A. Lopes committed
78 79 80
import Data.Maybe
import Data.Functor ((<$>))

81 82
-- * Exported types

83 84 85 86 87
-- | Class of objects that can be converted to 'JSObject'
-- lists-format.
class DictObject a where
  toDict :: a -> [(String, JSON.JSValue)]

88 89 90 91 92 93 94
-- | Optional field information.
data OptionalType
  = NotOptional           -- ^ Field is not optional
  | OptionalOmitNull      -- ^ Field is optional, null is not serialised
  | OptionalSerializeNull -- ^ Field is optional, null is serialised
  deriving (Show, Eq)

95 96 97 98 99
-- | Serialised field data type.
data Field = Field { fieldName        :: String
                   , fieldType        :: Q Type
                   , fieldRead        :: Maybe (Q Exp)
                   , fieldShow        :: Maybe (Q Exp)
Iustin Pop's avatar
Iustin Pop committed
100
                   , fieldExtraKeys   :: [String]
101 102
                   , fieldDefault     :: Maybe (Q Exp)
                   , fieldConstr      :: Maybe String
103
                   , fieldIsOptional  :: OptionalType
Jose A. Lopes's avatar
Jose A. Lopes committed
104
                   , fieldDoc         :: String
105 106 107 108 109 110 111 112 113
                   }

-- | Generates a simple field.
simpleField :: String -> Q Type -> Field
simpleField fname ftype =
  Field { fieldName        = fname
        , fieldType        = ftype
        , fieldRead        = Nothing
        , fieldShow        = Nothing
Iustin Pop's avatar
Iustin Pop committed
114
        , fieldExtraKeys   = []
115 116
        , fieldDefault     = Nothing
        , fieldConstr      = Nothing
117
        , fieldIsOptional  = NotOptional
Jose A. Lopes's avatar
Jose A. Lopes committed
118
        , fieldDoc         = ""
119 120
        }

Jose A. Lopes's avatar
Jose A. Lopes committed
121 122 123 124
withDoc :: String -> Field -> Field
withDoc doc field =
  field { fieldDoc = doc }

125 126 127 128 129 130 131 132 133 134 135
-- | 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
136 137 138 139 140 141
optionalField field = field { fieldIsOptional = OptionalOmitNull }

-- | Marks a field optional (turning its base type into a Maybe), but
-- with 'Nothing' serialised explicitly as /null/.
optionalNullSerField :: Field -> Field
optionalNullSerField field = field { fieldIsOptional = OptionalSerializeNull }
142 143

-- | Sets custom functions on a field.
Iustin Pop's avatar
Iustin Pop committed
144 145 146 147 148 149 150 151
customField :: Name      -- ^ The name of the read function
            -> Name      -- ^ The name of the show function
            -> [String]  -- ^ The name of extra field keys
            -> Field     -- ^ The original field
            -> Field     -- ^ Updated field
customField readfn showfn extra field =
  field { fieldRead = Just (varE readfn), fieldShow = Just (varE showfn)
        , fieldExtraKeys = extra }
152

153 154 155
-- | Computes the record name for a given field, based on either the
-- string value in the JSON serialisation or the custom named if any
-- exists.
156 157
fieldRecordName :: Field -> String
fieldRecordName (Field { fieldName = name, fieldConstr = alias }) =
158
  fromMaybe (camelCase name) alias
159

160 161 162 163
-- | 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'.
164
fieldVariable :: Field -> String
165 166 167
fieldVariable f =
  case (fieldConstr f) of
    Just name -> ensureLower name
Iustin Pop's avatar
Iustin Pop committed
168
    _ -> map (\c -> if c == '-' then '_' else c) $ fieldName f
169

170 171
-- | Compute the actual field type (taking into account possible
-- optional status).
172
actualFieldType :: Field -> Q Type
173
actualFieldType f | fieldIsOptional f /= NotOptional = [t| Maybe $t |]
174 175 176
                  | otherwise = t
                  where t = fieldType f

177 178
-- | Checks that a given field is not optional (for object types or
-- fields which should not allow this case).
179
checkNonOptDef :: (Monad m) => Field -> m ()
180 181 182 183 184
checkNonOptDef (Field { fieldIsOptional = OptionalOmitNull
                      , fieldName = name }) =
  fail $ "Optional field " ++ name ++ " used in parameter declaration"
checkNonOptDef (Field { fieldIsOptional = OptionalSerializeNull
                      , fieldName = name }) =
185 186 187 188 189
  fail $ "Optional field " ++ name ++ " used in parameter declaration"
checkNonOptDef (Field { fieldDefault = (Just _), fieldName = name }) =
  fail $ "Default field " ++ name ++ " used in parameter declaration"
checkNonOptDef _ = return ()

190 191 192 193 194 195 196 197 198 199
-- | 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 { fieldRead = Just readfn }) expr o = [| $expr >>= $readfn $o |]
loadFn _ expr _ = expr
200 201 202

-- * Common field declarations

203
-- | Timestamp fields description.
204 205 206 207 208 209
timeStampFields :: [Field]
timeStampFields =
    [ defaultField [| 0::Double |] $ simpleField "ctime" [t| Double |]
    , defaultField [| 0::Double |] $ simpleField "mtime" [t| Double |]
    ]

210
-- | Serial number fields description.
211 212 213 214
serialFields :: [Field]
serialFields =
    [ renameField  "Serial" $ simpleField "serial_no" [t| Int |] ]

215
-- | UUID fields description.
216 217 218
uuidFields :: [Field]
uuidFields = [ simpleField "uuid" [t| String |] ]

219 220 221
-- | Tag set type alias.
type TagSet = Set.Set String

Iustin Pop's avatar
Iustin Pop committed
222 223 224
-- | Tag field description.
tagsFields :: [Field]
tagsFields = [ defaultField [| Set.empty |] $
225
               simpleField "tags" [t| TagSet |] ]
Iustin Pop's avatar
Iustin Pop committed
226

Iustin Pop's avatar
Iustin Pop committed
227 228 229 230 231 232 233 234 235 236 237
-- * Internal types

-- | A simple field, in constrast to the customisable 'Field' type.
type SimpleField = (String, Q Type)

-- | A definition for a single constructor for a simple object.
type SimpleConstructor = (String, [SimpleField])

-- | A definition for ADTs with simple fields.
type SimpleObject = [SimpleConstructor]

Jose A. Lopes's avatar
Jose A. Lopes committed
238 239 240 241 242
-- | A type alias for an opcode constructor of a regular object.
type OpCodeConstructor = (String, Q Type, String, [Field], String)

-- | A type alias for a Luxi constructor of a regular object.
type LuxiConstructor = (String, [Field])
243

Iustin Pop's avatar
Iustin Pop committed
244 245
-- * Helper functions

246 247 248
-- | Ensure first letter is lowercase.
--
-- Used to convert type name to function prefix, e.g. in @data Aa ->
249
-- aaToRaw@.
250 251 252 253
ensureLower :: String -> String
ensureLower [] = []
ensureLower (x:xs) = toLower x:xs

254 255 256 257 258 259 260
-- | 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
261 262 263 264 265 266
-- | Helper for quoted expressions.
varNameE :: String -> Q Exp
varNameE = varE . mkName

-- | showJSON as an expression, for reuse.
showJSONE :: Q Exp
267 268 269 270 271 272 273 274 275
showJSONE = varE 'JSON.showJSON

-- | makeObj as an expression, for reuse.
makeObjE :: Q Exp
makeObjE = varE 'JSON.makeObj

-- | fromObj (Ganeti specific) as an expression, for reuse.
fromObjE :: Q Exp
fromObjE = varE 'fromObj
Iustin Pop's avatar
Iustin Pop committed
276

277 278 279
-- | ToRaw function name.
toRawName :: String -> Name
toRawName = mkName . (++ "ToRaw") . ensureLower
280

281 282 283
-- | FromRaw function name.
fromRawName :: String -> Name
fromRawName = mkName . (++ "FromRaw") . ensureLower
284

285
-- | Converts a name to it's varE\/litE representations.
286
reprE :: Either String Name -> Q Exp
Iustin Pop's avatar
Iustin Pop committed
287 288
reprE = either stringE varE

289 290 291 292 293 294 295 296
-- | 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

297 298 299 300 301 302 303 304 305 306 307 308
-- | Builds a field for a normal constructor.
buildConsField :: Q Type -> StrictTypeQ
buildConsField ftype = do
  ftype' <- ftype
  return (NotStrict, ftype')

-- | Builds a constructor based on a simple definition (not field-based).
buildSimpleCons :: Name -> SimpleObject -> Q Dec
buildSimpleCons tname cons = do
  decl_d <- mapM (\(cname, fields) -> do
                    fields' <- mapM (buildConsField . snd) fields
                    return $ NormalC (mkName cname) fields') cons
309
  return $ DataD [] tname [] decl_d [''Show, ''Eq]
310 311 312 313 314 315 316 317 318 319 320 321 322

-- | Generate the save function for a given type.
genSaveSimpleObj :: Name                            -- ^ Object type
                 -> String                          -- ^ Function name
                 -> SimpleObject                    -- ^ Object definition
                 -> (SimpleConstructor -> Q Clause) -- ^ Constructor save fn
                 -> Q (Dec, Dec)
genSaveSimpleObj tname sname opdefs fn = do
  let sigt = AppT (AppT ArrowT (ConT tname)) (ConT ''JSON.JSValue)
      fname = mkName sname
  cclauses <- mapM fn opdefs
  return $ (SigD fname sigt, FunD fname cclauses)

323
-- * Template code for simple raw type-equivalent ADTs
324

325 326 327 328 329
-- | Generates a data type declaration.
--
-- The type will have a fixed list of instances.
strADTDecl :: Name -> [String] -> Dec
strADTDecl name constructors =
330 331
  DataD [] name []
          (map (flip NormalC [] . mkName) constructors)
332
          [''Show, ''Eq, ''Enum, ''Bounded, ''Ord]
333

334
-- | Generates a toRaw function.
335 336 337 338
--
-- This generates a simple function of the form:
--
-- @
339 340 341
-- nameToRaw :: Name -> /traw/
-- nameToRaw Cons1 = var1
-- nameToRaw Cons2 = \"value2\"
342
-- @
343 344
genToRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec]
genToRaw traw fname tname constructors = do
345
  let sigt = AppT (AppT ArrowT (ConT tname)) (ConT traw)
346
  -- the body clauses, matching on the constructor and returning the
347
  -- raw value
348
  clauses <- mapM  (\(c, v) -> clause [recP (mkName c) []]
349
                             (normalB (reprE v)) []) constructors
350 351
  return [SigD fname sigt, FunD fname clauses]

352
-- | Generates a fromRaw function.
353 354
--
-- The function generated is monadic and can fail parsing the
355
-- raw value. It is of the form:
356 357
--
-- @
358 359 360 361
-- nameFromRaw :: (Monad m) => /traw/ -> m Name
-- nameFromRaw s | s == var1       = Cons1
--               | s == \"value2\" = Cons2
--               | otherwise = fail /.../
362
-- @
363 364
genFromRaw :: Name -> Name -> Name -> [(String, Name)] -> Q [Dec]
genFromRaw traw fname tname constructors = do
365
  -- signature of form (Monad m) => String -> m $name
366
  sigt <- [t| (Monad m) => $(conT traw) -> m $(conT tname) |]
367 368 369 370 371 372 373 374 375 376 377 378 379
  -- 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 " ++
380
                 $(litE (stringL (nameBase tname))) ++ ": " ++ show $varpe) |]
381 382 383 384 385
    return (g, r)
  let fun = FunD fname [Clause [VarP varp]
                        (GuardedB (clauses++[oth_clause])) []]
  return [SigD fname sigt, fun]

386
-- | Generates a data type from a given raw format.
387 388 389 390 391 392 393 394 395
--
-- 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:
--
396
-- * /name/ToRaw, which converts the type to a raw type
397
--
398
-- * /name/FromRaw, which (monadically) converts from a raw type to the type
399
--
400
-- Note that this is basically just a custom show\/read instance,
401
-- nothing else.
402 403
declareADT :: Name -> String -> [(String, Name)] -> Q [Dec]
declareADT traw sname cons = do
404 405
  let name = mkName sname
      ddecl = strADTDecl name (map fst cons)
406
      -- process cons in the format expected by genToRaw
407
      cons' = map (\(a, b) -> (a, Right b)) cons
408 409 410
  toraw <- genToRaw traw (toRawName sname) name cons'
  fromraw <- genFromRaw traw (fromRawName sname) name cons
  return $ ddecl:toraw ++ fromraw
411

412 413 414 415 416
declareIADT :: String -> [(String, Name)] -> Q [Dec]
declareIADT = declareADT ''Int

declareSADT :: String -> [(String, Name)] -> Q [Dec]
declareSADT = declareADT ''String
417 418 419 420 421 422

-- | Creates the showJSON member of a JSON instance declaration.
--
-- This will create what is the equivalent of:
--
-- @
423
-- showJSON = showJSON . /name/ToRaw
424 425 426
-- @
--
-- in an instance JSON /name/ declaration
427 428 429
genShowJSON :: String -> Q Dec
genShowJSON name = do
  body <- [| JSON.showJSON . $(varE (toRawName name)) |]
430
  return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []]
431 432 433 434 435 436 437

-- | Creates the readJSON member of a JSON instance declaration.
--
-- This will create what is the equivalent of:
--
-- @
-- readJSON s = case readJSON s of
438
--                Ok s' -> /name/FromRaw s'
439 440 441 442 443 444 445 446
--                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
447
               JSON.Ok s' -> $(varE (fromRawName name)) s'
448
               JSON.Error e ->
449
                   JSON.Error $ "Can't parse raw value for type " ++
450 451
                           $(stringE name) ++ ": " ++ e ++ " from " ++
                           show $(varE s)
452
           |]
453
  return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]
454 455 456

-- | Generates a JSON instance for a given type.
--
457
-- This assumes that the /name/ToRaw and /name/FromRaw functions
458 459 460 461 462 463
-- 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
464
  return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) [readJ,showJ]]
465

Iustin Pop's avatar
Iustin Pop committed
466 467
-- * Template code for opcodes

468 469 470 471 472
-- | Transforms a CamelCase string into an_underscore_based_one.
deCamelCase :: String -> String
deCamelCase =
    intercalate "_" . map (map toUpper) . groupBy (\_ b -> not $ isUpper b)

473 474 475
-- | Transform an underscore_name into a CamelCase one.
camelCase :: String -> String
camelCase = concatMap (ensureUpper . drop 1) .
Iustin Pop's avatar
Iustin Pop committed
476
            groupBy (\_ b -> b /= '_' && b /= '-') . ('_':)
477

478
-- | Computes the name of a given constructor.
479 480 481 482 483
constructorName :: Con -> Q Name
constructorName (NormalC name _) = return name
constructorName (RecC name _)    = return name
constructorName x                = fail $ "Unhandled constructor " ++ show x

484 485 486 487 488 489 490 491 492
-- | Extract all constructor names from a given type.
reifyConsNames :: Name -> Q [String]
reifyConsNames name = do
  reify_result <- reify name
  case reify_result of
    TyConI (DataD _ _ _ cons _) -> mapM (liftM nameBase . constructorName) cons
    o -> fail $ "Unhandled name passed to reifyConsNames, expected\
                \ type constructor but got '" ++ show o ++ "'"

493
-- | Builds the generic constructor-to-string function.
494 495 496 497
--
-- This generates a simple function of the following form:
--
-- @
498 499
-- fname (ConStructorOne {}) = trans_fun("ConStructorOne")
-- fname (ConStructorTwo {}) = trans_fun("ConStructorTwo")
500 501
-- @
--
502 503
-- This builds a custom list of name\/string pairs and then uses
-- 'genToRaw' to actually generate the function.
504 505
genConstrToStr :: (String -> String) -> Name -> String -> Q [Dec]
genConstrToStr trans_fun name fname = do
506
  cnames <- reifyConsNames name
507
  let svalues = map (Left . trans_fun) cnames
508
  genToRaw ''String (mkName fname) name $ zip cnames svalues
509

510 511 512
-- | Constructor-to-string for OpCode.
genOpID :: Name -> String -> Q [Dec]
genOpID = genConstrToStr deCamelCase
513

514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535
-- | Builds a list with all defined constructor names for a type.
--
-- @
-- vstr :: String
-- vstr = [...]
-- @
--
-- Where the actual values of the string are the constructor names
-- mapped via @trans_fun@.
genAllConstr :: (String -> String) -> Name -> String -> Q [Dec]
genAllConstr trans_fun name vstr = do
  cnames <- reifyConsNames name
  let svalues = sort $ map trans_fun cnames
      vname = mkName vstr
      sig = SigD vname (AppT ListT (ConT ''String))
      body = NormalB (ListE (map (LitE . StringL) svalues))
  return $ [sig, ValD (VarP vname) body []]

-- | Generates a list of all defined opcode IDs.
genAllOpIDs :: Name -> String -> Q [Dec]
genAllOpIDs = genAllConstr deCamelCase

536
-- | OpCode parameter (field) type.
537 538
type OpParam = (String, Q Type, Q Exp)

Jose A. Lopes's avatar
Jose A. Lopes committed
539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 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 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 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 695 696 697 698 699
-- * Python code generation

-- | Converts Haskell values into Python values
--
-- This is necessary for the default values of opcode parameters and
-- return values.  For example, if a default value or return type is a
-- Data.Map, then it must be shown as a Python dictioanry.
class Show a => PyValue a where
  showValue :: a -> String
  showValue = show

-- | Encapsulates Python default values
data PyValueEx = forall a. PyValue a => PyValueEx a

-- | Transfers opcode data between the opcode description (through
-- @genOpCode@) and the Python code generation functions.
type OpCodeDescriptor =
  (String, String, String, [String],
   [String], [Maybe PyValueEx], [String], String)

-- | Strips out the module name
--
-- @
-- pyBaseName "Data.Map" = "Map"
-- @
pyBaseName :: String -> String
pyBaseName str =
  case span (/= '.') str of
    (x, []) -> x
    (_, _:x) -> pyBaseName x

-- | Converts a Haskell type name into a Python type name.
--
-- @
-- pyTypename "Bool" = "ht.TBool"
-- @
pyTypeName :: Show a => a -> String
pyTypeName name =
  "ht.T" ++ (case pyBaseName (show name) of
                "()" -> "None"
                "Map" -> "DictOf"
                "Set" -> "SetOf"
                "Either" -> "Or"
                "GenericContainer" -> "DictOf"
                "JSValue" -> "Any"
                "JSObject" -> "Object"
                str -> str)

-- | Converts a Haskell type into a Python type.
--
-- @
-- pyType [Int] = "ht.TListOf(ht.TInt)"
-- @
pyType :: Type -> Q String
pyType (AppT typ1 typ2) =
  do t <- pyCall typ1 typ2
     return $ t ++ ")"

pyType (ConT name) = return (pyTypeName name)
pyType ListT = return "ht.TListOf"
pyType (TupleT _) = return "ht.TTupleOf"
pyType typ = error $ "unhandled case for type " ++ show typ
        
-- | Converts a Haskell type application into a Python type.
--
-- @
-- Maybe Int = "ht.TMaybe(ht.TInt)"
-- @
pyCall :: Type -> Type -> Q String
pyCall (AppT typ1 typ2) arg =
  do t <- pyCall typ1 typ2
     targ <- pyType arg
     return $ t ++ ", " ++ targ

pyCall typ1 typ2 =
  do t1 <- pyType typ1
     t2 <- pyType typ2
     return $ t1 ++ "(" ++ t2

-- | @pyType opt typ@ converts Haskell type @typ@ into a Python type,
-- where @opt@ determines if the converted type is optional (i.e.,
-- Maybe).
--
-- @
-- pyType False [Int] = "ht.TListOf(ht.TInt)" (mandatory)
-- pyType True [Int] = "ht.TMaybe(ht.TListOf(ht.TInt))" (optional)
-- @
pyOptionalType :: Bool -> Type -> Q String
pyOptionalType opt typ
  | opt = do t <- pyType typ
             return $ "ht.TMaybe(" ++ t ++ ")"
  | otherwise = pyType typ

-- | Optionally encapsulates default values in @PyValueEx@.
--
-- @maybeApp exp typ@ returns a quoted expression that encapsulates
-- the default value @exp@ of an opcode parameter cast to @typ@ in a
-- @PyValueEx@, if @exp@ is @Just@.  Otherwise, it returns a quoted
-- expression with @Nothing@.
maybeApp :: Maybe (Q Exp) -> Q Type -> Q Exp
maybeApp Nothing _ =
  [| Nothing |]

maybeApp (Just expr) typ =
  [| Just ($(conE (mkName "PyValueEx")) ($expr :: $typ)) |]


-- | Generates a Python type according to whether the field is
-- optional
genPyType :: OptionalType -> Q Type -> Q ExpQ
genPyType opt typ =
  do t <- typ
     stringE <$> pyOptionalType (opt /= NotOptional) t

-- | Generates Python types from opcode parameters.
genPyTypes :: [Field] -> Q ExpQ
genPyTypes fs =
  listE <$> mapM (\f -> genPyType (fieldIsOptional f) (fieldType f)) fs

-- | Generates Python default values from opcode parameters.
genPyDefaults :: [Field] -> ExpQ
genPyDefaults fs =
  listE $ map (\f -> maybeApp (fieldDefault f) (fieldType f)) fs

-- | Generates a Haskell function call to "showPyClass" with the
-- necessary information on how to build the Python class string.
pyClass :: OpCodeConstructor -> ExpQ
pyClass (consName, consType, consDoc, consFields, consDscField) =
  do let pyClassVar = varNameE "showPyClass"
         consName' = stringE consName
     consType' <- genPyType NotOptional consType
     let consDoc' = stringE consDoc
         consFieldNames = listE $ map (stringE . fieldName) consFields
         consFieldDocs = listE $ map (stringE . fieldDoc) consFields
     consFieldTypes <- genPyTypes consFields
     let consFieldDefaults = genPyDefaults consFields
     [| ($consName',
         $consType',
         $consDoc',
         $consFieldNames,
         $consFieldTypes,
         $consFieldDefaults,
         $consFieldDocs,
         consDscField) |]

-- | Generates a function called "pyClasses" that holds the list of
-- all the opcode descriptors necessary for generating the Python
-- opcodes.
pyClasses :: [OpCodeConstructor] -> Q [Dec]
pyClasses cons =
  do let name = mkName "pyClasses"
         sig = SigD name (AppT ListT (ConT ''OpCodeDescriptor))
     fn <- FunD name <$> (:[]) <$> declClause cons
     return [sig, fn]
  where declClause c =
          clause [] (normalB (ListE <$> mapM pyClass c)) []

-- | Converts from an opcode constructor to a Luxi constructor.
opcodeConsToLuxiCons :: (a, b, c, d, e) -> (a, d)
opcodeConsToLuxiCons (x, _, _, y, _) = (x, y)

700 701 702 703 704 705
-- | 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.
Jose A. Lopes's avatar
Jose A. Lopes committed
706 707
genOpCode :: String              -- ^ Type name to use
          -> [OpCodeConstructor] -- ^ Constructor name and parameters
708 709
          -> Q [Dec]
genOpCode name cons = do
710
  let tname = mkName name
Jose A. Lopes's avatar
Jose A. Lopes committed
711
  decl_d <- mapM (\(cname, _, _, fields, _) -> do
712
                    -- we only need the type of the field, without Q
713 714
                    fields' <- mapM (fieldTypeInfo "op") fields
                    return $ RecC (mkName cname) fields')
715
            cons
716
  let declD = DataD [] tname [] decl_d [''Show, ''Eq]
717
  let (allfsig, allffn) = genAllOpFields "allOpFields" cons
718
  save_decs <- genSaveOpCode tname "saveOpCode" "toDictOpCode"
Jose A. Lopes's avatar
Jose A. Lopes committed
719
               (map opcodeConsToLuxiCons cons) saveConstructor True
720
  (loadsig, loadfn) <- genLoadOpCode cons
Jose A. Lopes's avatar
Jose A. Lopes committed
721 722
  pyDecls <- pyClasses cons
  return $ [declD, allfsig, allffn, loadsig, loadfn] ++ save_decs ++ pyDecls
723 724 725

-- | Generates the function pattern returning the list of fields for a
-- given constructor.
Jose A. Lopes's avatar
Jose A. Lopes committed
726 727
genOpConsFields :: OpCodeConstructor -> Clause
genOpConsFields (cname, _, _, fields, _) =
728 729 730 731 732 733
  let op_id = deCamelCase cname
      fvals = map (LitE . StringL) . sort . nub $
              concatMap (\f -> fieldName f:fieldExtraKeys f) fields
  in Clause [LitP (StringL op_id)] (NormalB $ ListE fvals) []

-- | Generates a list of all fields of an opcode constructor.
Jose A. Lopes's avatar
Jose A. Lopes committed
734 735
genAllOpFields  :: String              -- ^ Function name
                -> [OpCodeConstructor] -- ^ Object definition
736 737 738 739 740 741 742
                -> (Dec, Dec)
genAllOpFields sname opdefs =
  let cclauses = map genOpConsFields opdefs
      other = Clause [WildP] (NormalB (ListE [])) []
      fname = mkName sname
      sigt = AppT  (AppT ArrowT (ConT ''String)) (AppT ListT (ConT ''String))
  in (SigD fname sigt, FunD fname (cclauses++[other]))
743 744 745 746 747

-- | 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),
748
-- and passes those name plus the parameter definition to 'saveObjectField'.
Jose A. Lopes's avatar
Jose A. Lopes committed
749 750 751
saveConstructor :: LuxiConstructor -- ^ The constructor
                -> Q Clause        -- ^ Resulting clause
saveConstructor (sname, fields) = do
752
  let cname = mkName sname
Iustin Pop's avatar
Iustin Pop committed
753
  fnames <- mapM (newName . fieldVariable) fields
754
  let pat = conP cname (map varP fnames)
755
  let felems = map (uncurry saveObjectField) (zip fnames fields)
756
      -- now build the OP_ID serialisation
Iustin Pop's avatar
Iustin Pop committed
757
      opid = [| [( $(stringE "OP_ID"),
758
                   JSON.showJSON $(stringE . deCamelCase $ sname) )] |]
759 760
      flist = listE (opid:felems)
      -- and finally convert all this to a json object
761
      flist' = [| concat $flist |]
762 763 764 765 766 767
  clause [pat] (normalB flist') []

-- | Generates the main save opcode function.
--
-- This builds a per-constructor match clause that contains the
-- respective constructor-serialisation code.
Jose A. Lopes's avatar
Jose A. Lopes committed
768 769 770 771 772 773 774 775
genSaveOpCode :: Name                          -- ^ Object ype
              -> String                        -- ^ To 'JSValue' function name
              -> String                        -- ^ To 'JSObject' function name
              -> [LuxiConstructor]             -- ^ Object definition
              -> (LuxiConstructor -> Q Clause) -- ^ Constructor save fn
              -> Bool                          -- ^ Whether to generate
                                               -- obj or just a
                                               -- list\/tuple of values
776 777 778 779 780 781 782 783 784 785 786 787 788 789 790
              -> Q [Dec]
genSaveOpCode tname jvalstr tdstr opdefs fn gen_object = do
  tdclauses <- mapM fn opdefs
  let typecon = ConT tname
      jvalname = mkName jvalstr
      jvalsig = AppT  (AppT ArrowT typecon) (ConT ''JSON.JSValue)
      tdname = mkName tdstr
  tdsig <- [t| $(return typecon) -> [(String, JSON.JSValue)] |]
  jvalclause <- if gen_object
                  then [| $makeObjE . $(varE tdname) |]
                  else [| JSON.showJSON . map snd . $(varE tdname) |]
  return [ SigD tdname tdsig
         , FunD tdname tdclauses
         , SigD jvalname jvalsig
         , ValD (VarP jvalname) (NormalB jvalclause) []]
791

792
-- | Generates load code for a single constructor of the opcode data type.
Jose A. Lopes's avatar
Jose A. Lopes committed
793 794
loadConstructor :: OpCodeConstructor -> Q Exp
loadConstructor (sname, _, _, fields, _) = do
795
  let name = mkName sname
796
  fbinds <- mapM loadObjectField fields
797 798 799 800 801
  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'

802
-- | Generates the loadOpCode function.
Jose A. Lopes's avatar
Jose A. Lopes committed
803
genLoadOpCode :: [OpCodeConstructor] -> Q (Dec, Dec)
804 805 806 807 808 809 810
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)) |]
811
  st2 <- bindS (varP opid) [| $fromObjE $(varE objname) $(stringE "OP_ID") |]
812
  -- the match results (per-constructor blocks)
Jose A. Lopes's avatar
Jose A. Lopes committed
813
  mexps <- mapM loadConstructor opdefs
814
  fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |]
Jose A. Lopes's avatar
Jose A. Lopes committed
815 816
  let mpats = map (\(me, (consName, _, _, _, _)) ->
                       let mp = LitP . StringL . deCamelCase $ consName
817 818 819 820 821 822 823 824
                       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) []])

825 826 827 828 829 830 831 832 833 834 835 836 837
-- * 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

-- | Generates the LuxiOp data type.
--
-- This takes a Luxi operation definition and builds both the
838
-- datatype and the function transforming the arguments to JSON.
839 840 841
-- We can't use anything less generic, because the way different
-- operations are serialized differs on both parameter- and top-level.
--
842
-- There are two things to be defined for each parameter:
843 844 845 846 847
--
-- * name
--
-- * type
--
Jose A. Lopes's avatar
Jose A. Lopes committed
848
genLuxiOp :: String -> [LuxiConstructor] -> Q [Dec]
849
genLuxiOp name cons = do
850
  let tname = mkName name
851 852 853 854 855 856
  decl_d <- mapM (\(cname, fields) -> do
                    -- we only need the type of the field, without Q
                    fields' <- mapM actualFieldType fields
                    let fields'' = zip (repeat NotStrict) fields'
                    return $ NormalC (mkName cname) fields'')
            cons
857
  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Eq]
858 859
  save_decs <- genSaveOpCode tname "opToArgs" "opToDict"
               cons saveLuxiConstructor False
Iustin Pop's avatar
Iustin Pop committed
860 861 862
  req_defs <- declareSADT "LuxiReq" .
              map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $
                  cons
863
  return $ declD:save_decs ++ req_defs
864 865

-- | Generates the \"save\" clause for entire LuxiOp constructor.
Jose A. Lopes's avatar
Jose A. Lopes committed
866
saveLuxiConstructor :: LuxiConstructor -> Q Clause
867
saveLuxiConstructor (sname, fields) = do
868
  let cname = mkName sname
869 870 871
  fnames <- mapM (newName . fieldVariable) fields
  let pat = conP cname (map varP fnames)
  let felems = map (uncurry saveObjectField) (zip fnames fields)
872
      flist = [| concat $(listE felems) |]
873
  clause [pat] (normalB flist) []
874

875 876 877 878 879 880 881 882 883 884 885 886 887 888 889
-- * "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
890
  let declD = DataD [] name [] [decl_d] [''Show, ''Eq]
891 892 893
  ser_decls <- buildObjectSerialisation sname fields
  return $ declD:ser_decls

894
-- | Generates an object definition: data type and its JSON instance.
895 896 897 898 899 900 901 902
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))
903
                 [rdjson, shjson]
904 905
  return $ savedecls ++ [loadsig, loadfn, instdecl]

906 907 908 909
-- | The toDict function name for a given type.
toDictName :: String -> Name
toDictName sname = mkName ("toDict" ++ sname)

910
-- | Generates the save object functionality.
911 912 913 914
genSaveObject :: (Name -> Field -> Q Exp)
              -> String -> [Field] -> Q [Dec]
genSaveObject save_fn sname fields = do
  let name = mkName sname
Iustin Pop's avatar
Iustin Pop committed
915
  fnames <- mapM (newName . fieldVariable) fields
916
  let pat = conP name (map varP fnames)
917
  let tdname = toDictName sname
918 919 920 921 922 923 924 925
  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) []
926
  cclause <- [| $makeObjE . $(varE tdname) |]
927 928 929 930 931
  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) []]

932 933
-- | Generates the code for saving an object's field, handling the
-- various types of fields that we have.
934
saveObjectField :: Name -> Field -> Q Exp
935 936 937 938 939 940 941 942 943 944 945 946
saveObjectField fvar field =
  case fieldIsOptional field of
    OptionalOmitNull -> [| case $(varE fvar) of
                             Nothing -> []
                             Just v  -> [( $nameE, JSON.showJSON v )]
                         |]
    OptionalSerializeNull -> [| case $(varE fvar) of
                                  Nothing -> [( $nameE, JSON.JSNull )]
                                  Just v  -> [( $nameE, JSON.showJSON v )]
                              |]
    NotOptional ->
      case fieldShow field of
947 948 949
        -- Note: the order of actual:extra is important, since for
        -- some serialisation types (e.g. Luxi), we use tuples
        -- (positional info) rather than object (name info)
950 951
        Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |]
        Just fn -> [| let (actual, extra) = $fn $fvarE
952
                      in ($nameE, JSON.showJSON actual):extra
953 954
                    |]
  where nameE = stringE (fieldName field)
955 956
        fvarE = varE fvar

957
-- | Generates the showJSON clause for a given object name.
958 959 960
objectShowJSON :: String -> Q Dec
objectShowJSON name = do
  body <- [| JSON.showJSON . $(varE . mkName $ "save" ++ name) |]
961
  return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []]
962

963
-- | Generates the load object functionality.
964 965 966 967 968
genLoadObject :: (Field -> Q (Name, Stmt))
              -> String -> [Field] -> Q (Dec, Dec)
genLoadObject load_fn sname fields = do
  let name = mkName sname
      funname = mkName $ "load" ++ sname
969
      arg1 = mkName $ if null fields then "_" else "v"
970 971 972 973 974 975 976
      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
977 978 979 980 981 982
      retstmt = [NoBindS (AppE (VarE 'return) cval)]
      -- FIXME: should we require an empty dict for an empty type?
      -- this allows any JSValue right now
      fstmts' = if null fields
                  then retstmt
                  else st1:fstmts ++ retstmt
983 984 985 986
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT name) |]
  return $ (SigD funname sigt,
            FunD funname [Clause [VarP arg1] (NormalB (DoE fstmts')) []])

987
-- | Generates code for loading an object's field.
988 989 990
loadObjectField :: Field -> Q (Name, Stmt)
loadObjectField field = do
  let name = fieldVariable field
Iustin Pop's avatar
Iustin Pop committed
991
  fvar <- newName name
992 993 994 995
  -- these are used in all patterns below
  let objvar = varNameE "o"
      objfield = stringE (fieldName field)
      loadexp =
996 997 998 999
        if fieldIsOptional field /= NotOptional
          -- we treat both optional types the same, since
          -- 'maybeFromObj' can deal with both missing and null values
          -- appropriately (the same)
1000
          then [| $(varE 'maybeFromObj) $objvar $objfield |]
1001 1002
          else case fieldDefault field of
                 Just defv ->
1003
                   [| $(varE 'fromObjWithDefault) $objvar
1004
                      $objfield $defv |]
1005
                 Nothing -> [| $fromObjE $objvar $objfield |]
1006
  bexp <- loadFn field loadexp objvar
1007 1008 1009

  return (fvar, BindS (VarP fvar) bexp)

1010
-- | Builds the readJSON instance for a given object name.
1011 1012 1013 1014 1015 1016 1017 1018 1019
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
           |]
1020
  return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]
1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052

-- * 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
1053 1054
  let declF = DataD [] name_f [] [decl_f] [''Show, ''Eq]
      declP = DataD [] name_p [] [decl_p] [''Show, ''Eq]
1055 1056 1057
  ser_decls_f <- buildObjectSerialisation sname_f fields
  ser_decls_p <- buildPParamSerialisation sname_p fields
  fill_decls <- fillParam sname field_pfx fields