code.grnet.gr Git - ganeti-local/blob - htools/Ganeti/THH.hs

   1 {-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
   2
   3 {-| TemplateHaskell helper for HTools.
   4
   5 As TemplateHaskell require that splices be defined in a separate
   6 module, we combine all the TemplateHaskell functionality that HTools
   7 needs in this module (except the one for unittests).
   8
   9 -}
  10
  11 {-
  12
  13 Copyright (C) 2011 Google Inc.
  14
  15 This program is free software; you can redistribute it and/or modify
  16 it under the terms of the GNU General Public License as published by
  17 the Free Software Foundation; either version 2 of the License, or
  18 (at your option) any later version.
  19
  20 This program is distributed in the hope that it will be useful, but
  21 WITHOUT ANY WARRANTY; without even the implied warranty of
  22 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  23 General Public License for more details.
  24
  25 You should have received a copy of the GNU General Public License
  26 along with this program; if not, write to the Free Software
  27 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  28 02110-1301, USA.
  29
  30 -}
  31
  32 module Ganeti.THH ( declareSADT
  33                   , declareIADT
  34                   , makeJSONInstance
  35                   , makeJSONInstanceInt
  36                   , genOpID
  37                   , genOpCode
  38                   , noDefault
  39                   , genStrOfOp
  40                   , genStrOfKey
  41                   , genLuxiOp
  42                   ) where
  43
  44 import Control.Monad (liftM, liftM2)
  45 import Data.Char
  46 import Data.List
  47 import Language.Haskell.TH
  48
  49 import qualified Text.JSON as JSON
  50
  51 -- * Helper functions
  52
  53 -- | Ensure first letter is lowercase.
  54 --
  55 -- Used to convert type name to function prefix, e.g. in @data Aa ->
  56 -- aaToString@.
  57 ensureLower :: String -> String
  58 ensureLower [] = []
  59 ensureLower (x:xs) = toLower x:xs
  60
  61 -- | Helper for quoted expressions.
  62 varNameE :: String -> Q Exp
  63 varNameE = varE . mkName
  64
  65 -- | showJSON as an expression, for reuse.
  66 showJSONE :: Q Exp
  67 showJSONE = varNameE "showJSON"
  68
  69 -- | ToString function name.
  70 toStrName :: String -> Name
  71 toStrName = mkName . (++ "ToString") . ensureLower
  72
  73 -- | ToInt function name.
  74 toIntName :: String -> Name
  75 toIntName= mkName . (++ "ToInt") . ensureLower
  76
  77 -- | FromString function name.
  78 fromStrName :: String -> Name
  79 fromStrName = mkName . (++ "FromString") . ensureLower
  80
  81 -- | FromInt function name.
  82 fromIntName:: String -> Name
  83 fromIntName = mkName . (++ "FromInt") . ensureLower
  84
  85 -- | Converts a name to it's varE/litE representations.
  86 --
  87 reprE :: Either String Name -> Q Exp
  88 reprE = either stringE varE
  89
  90 -- | Smarter function application.
  91 --
  92 -- This does simply f x, except that if is 'id', it will skip it, in
  93 -- order to generate more readable code when using -ddump-splices.
  94 appFn :: Exp -> Exp -> Exp
  95 appFn f x | f == VarE 'id = x
  96           | otherwise = AppE f x
  97
  98 -- * Template code for simple integer-equivalent ADTs
  99
 100 -- | Generates a data type declaration.
 101 --
 102 -- The type will have a fixed list of instances.
 103 intADTDecl :: Name -> [String] -> Dec
 104 intADTDecl name constructors =
 105     DataD [] name []
 106               (map (flip NormalC [] . mkName) constructors)
 107               [''Show]
 108
 109 -- | Generates a toInt function.
 110 genToInt :: Name -> Name -> [(String, Name)] -> Q [Dec]
 111 genToInt fname tname constructors = do
 112   sigt <- [t| $(conT tname) -> Int |]
 113   clauses <- mapM  (\(c, v) -> clause [recP (mkName c) []]
 114                              (normalB (varE v)) []) constructors
 115   return [SigD fname sigt, FunD fname clauses]
 116
 117 -- | Generates a fromInt function.
 118 genFromInt :: Name -> Name -> [(String, Name)] -> Q [Dec]
 119 genFromInt fname tname constructors = do
 120   sigt <- [t| (Monad m) => Int-> m $(conT tname) |]
 121   let varp = mkName "s"
 122       varpe = varE varp
 123   clauses <- mapM (\(c, v) -> do
 124                      g <- normalG [| $varpe == $(varE v) |]
 125                      r <- [| return $(conE (mkName c)) |]
 126                      return (g, r)) constructors
 127   oth_clause <- do
 128     g <- normalG [| otherwise |]
 129     r <- [|fail ("Invalid int value for type " ++
 130                  $(litE (stringL (nameBase tname))) ++ ": " ++ show $varpe) |]
 131     return (g, r)
 132   let fun = FunD fname [Clause [VarP varp]
 133                         (GuardedB (clauses++[oth_clause])) []]
 134   return [SigD fname sigt, fun]
 135
 136 -- | Generates a data type from a given string format.
 137 declareIADT:: String -> [(String, Name)] -> Q [Dec]
 138 declareIADT sname cons = do
 139   let name = mkName sname
 140       ddecl = intADTDecl name (map fst cons)
 141   tostr <- genToInt (toIntName sname) name cons
 142   fromstr <- genFromInt (fromIntName sname) name cons
 143   return $ ddecl:tostr ++ fromstr
 144
 145 -- | Creates the showJSON member of a JSON instance declaration.
 146 genShowJSONInt :: String -> Q [Dec]
 147 genShowJSONInt name = [d| showJSON = JSON.showJSON . $(varE (toIntName name)) |]
 148
 149 -- | Creates the readJSON member of a JSON instance declaration.
 150 genReadJSONInt :: String -> Q Dec
 151 genReadJSONInt name = do
 152   let s = mkName "s"
 153   body <- [| case JSON.readJSON $(varE s) of
 154                JSON.Ok s' -> $(varE (fromIntName name)) s'
 155                JSON.Error e ->
 156                    JSON.Error $ "Can't parse int value for type " ++
 157                            $(stringE name) ++ ": " ++ e
 158            |]
 159   return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []]
 160
 161 -- | Generates a JSON instance for a given type.
 162 makeJSONInstanceInt :: Name -> Q [Dec]
 163 makeJSONInstanceInt name = do
 164   let base = nameBase name
 165   showJ <- genShowJSONInt base
 166   readJ <- genReadJSONInt base
 167   return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) (readJ:showJ)]
 168
 169 -- * Template code for simple string-equivalent ADTs
 170
 171 -- | Generates a data type declaration.
 172 --
 173 -- The type will have a fixed list of instances.
 174 strADTDecl :: Name -> [String] -> Dec
 175 strADTDecl name constructors =
 176     DataD [] name []
 177               (map (flip NormalC [] . mkName) constructors)
 178               [''Show, ''Read, ''Eq, ''Enum, ''Bounded, ''Ord]
 179
 180 -- | Generates a toString function.
 181 --
 182 -- This generates a simple function of the form:
 183 --
 184 -- @
 185 -- nameToString :: Name -> String
 186 -- nameToString Cons1 = var1
 187 -- nameToString Cons2 = \"value2\"
 188 -- @
 189 genToString :: Name -> Name -> [(String, Either String Name)] -> Q [Dec]
 190 genToString fname tname constructors = do
 191   sigt <- [t| $(conT tname) -> String |]
 192   -- the body clauses, matching on the constructor and returning the
 193   -- string value
 194   clauses <- mapM  (\(c, v) -> clause [recP (mkName c) []]
 195                              (normalB (reprE v)) []) constructors
 196   return [SigD fname sigt, FunD fname clauses]
 197
 198 -- | Generates a fromString function.
 199 --
 200 -- The function generated is monadic and can fail parsing the
 201 -- string. It is of the form:
 202 --
 203 -- @
 204 -- nameFromString :: (Monad m) => String -> m Name
 205 -- nameFromString s | s == var1       = Cons1
 206 --                  | s == \"value2\" = Cons2
 207 --                  | otherwise = fail /.../
 208 -- @
 209 genFromString :: Name -> Name -> [(String, Name)] -> Q [Dec]
 210 genFromString fname tname constructors = do
 211   -- signature of form (Monad m) => String -> m $name
 212   sigt <- [t| (Monad m) => String -> m $(conT tname) |]
 213   -- clauses for a guarded pattern
 214   let varp = mkName "s"
 215       varpe = varE varp
 216   clauses <- mapM (\(c, v) -> do
 217                      -- the clause match condition
 218                      g <- normalG [| $varpe == $(varE v) |]
 219                      -- the clause result
 220                      r <- [| return $(conE (mkName c)) |]
 221                      return (g, r)) constructors
 222   -- the otherwise clause (fallback)
 223   oth_clause <- do
 224     g <- normalG [| otherwise |]
 225     r <- [|fail ("Invalid string value for type " ++
 226                  $(litE (stringL (nameBase tname))) ++ ": " ++ $varpe) |]
 227     return (g, r)
 228   let fun = FunD fname [Clause [VarP varp]
 229                         (GuardedB (clauses++[oth_clause])) []]
 230   return [SigD fname sigt, fun]
 231
 232 -- | Generates a data type from a given string format.
 233 --
 234 -- The format is expected to multiline. The first line contains the
 235 -- type name, and the rest of the lines must contain two words: the
 236 -- constructor name and then the string representation of the
 237 -- respective constructor.
 238 --
 239 -- The function will generate the data type declaration, and then two
 240 -- functions:
 241 --
 242 -- * /name/ToString, which converts the type to a string
 243 --
 244 -- * /name/FromString, which (monadically) converts from a string to the type
 245 --
 246 -- Note that this is basically just a custom show/read instance,
 247 -- nothing else.
 248 declareSADT :: String -> [(String, Name)] -> Q [Dec]
 249 declareSADT sname cons = do
 250   let name = mkName sname
 251       ddecl = strADTDecl name (map fst cons)
 252       -- process cons in the format expected by genToString
 253       cons' = map (\(a, b) -> (a, Right b)) cons
 254   tostr <- genToString (toStrName sname) name cons'
 255   fromstr <- genFromString (fromStrName sname) name cons
 256   return $ ddecl:tostr ++ fromstr
 257
 258
 259 -- | Creates the showJSON member of a JSON instance declaration.
 260 --
 261 -- This will create what is the equivalent of:
 262 --
 263 -- @
 264 -- showJSON = showJSON . /name/ToString
 265 -- @
 266 --
 267 -- in an instance JSON /name/ declaration
 268 genShowJSON :: String -> Q [Dec]
 269 genShowJSON name = [d| showJSON = JSON.showJSON . $(varE (toStrName name)) |]
 270
 271 -- | Creates the readJSON member of a JSON instance declaration.
 272 --
 273 -- This will create what is the equivalent of:
 274 --
 275 -- @
 276 -- readJSON s = case readJSON s of
 277 --                Ok s' -> /name/FromString s'
 278 --                Error e -> Error /description/
 279 -- @
 280 --
 281 -- in an instance JSON /name/ declaration
 282 genReadJSON :: String -> Q Dec
 283 genReadJSON name = do
 284   let s = mkName "s"
 285   body <- [| case JSON.readJSON $(varE s) of
 286                JSON.Ok s' -> $(varE (fromStrName name)) s'
 287                JSON.Error e ->
 288                    JSON.Error $ "Can't parse string value for type " ++
 289                            $(stringE name) ++ ": " ++ e
 290            |]
 291   return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []]
 292
 293 -- | Generates a JSON instance for a given type.
 294 --
 295 -- This assumes that the /name/ToString and /name/FromString functions
 296 -- have been defined as by the 'declareSADT' function.
 297 makeJSONInstance :: Name -> Q [Dec]
 298 makeJSONInstance name = do
 299   let base = nameBase name
 300   showJ <- genShowJSON base
 301   readJ <- genReadJSON base
 302   return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) (readJ:showJ)]
 303
 304 -- * Template code for opcodes
 305
 306 -- | Transforms a CamelCase string into an_underscore_based_one.
 307 deCamelCase :: String -> String
 308 deCamelCase =
 309     intercalate "_" . map (map toUpper) . groupBy (\_ b -> not $ isUpper b)
 310
 311 -- | Computes the name of a given constructor.
 312 constructorName :: Con -> Q Name
 313 constructorName (NormalC name _) = return name
 314 constructorName (RecC name _)    = return name
 315 constructorName x                = fail $ "Unhandled constructor " ++ show x
 316
 317 -- | Builds the generic constructor-to-string function.
 318 --
 319 -- This generates a simple function of the following form:
 320 --
 321 -- @
 322 -- fname (ConStructorOne {}) = trans_fun("ConStructorOne")
 323 -- fname (ConStructorTwo {}) = trans_fun("ConStructorTwo")
 324 -- @
 325 --
 326 -- This builds a custom list of name/string pairs and then uses
 327 -- 'genToString' to actually generate the function
 328 genConstrToStr :: (String -> String) -> Name -> String -> Q [Dec]
 329 genConstrToStr trans_fun name fname = do
 330   TyConI (DataD _ _ _ cons _) <- reify name
 331   cnames <- mapM (liftM nameBase . constructorName) cons
 332   let svalues = map (Left . trans_fun) cnames
 333   genToString (mkName fname) name $ zip cnames svalues
 334
 335 -- | Constructor-to-string for OpCode.
 336 genOpID :: Name -> String -> Q [Dec]
 337 genOpID = genConstrToStr deCamelCase
 338
 339 -- | OpCode parameter (field) type.
 340 type OpParam = (String, Q Type, Q Exp)
 341
 342 -- | Generates the OpCode data type.
 343 --
 344 -- This takes an opcode logical definition, and builds both the
 345 -- datatype and the JSON serialisation out of it. We can't use a
 346 -- generic serialisation since we need to be compatible with Ganeti's
 347 -- own, so we have a few quirks to work around.
 348 --
 349 -- There are three things to be defined for each parameter:
 350 --
 351 -- * name
 352 --
 353 -- * type; if this is 'Maybe', will only be serialised if it's a
 354 --   'Just' value
 355 --
 356 -- * default; if missing, won't raise an exception, but will instead
 357 --   use the default
 358 --
 359 genOpCode :: String                -- ^ Type name to use
 360           -> [(String, [OpParam])] -- ^ Constructor name and parameters
 361           -> Q [Dec]
 362 genOpCode name cons = do
 363   decl_d <- mapM (\(cname, fields) -> do
 364                     -- we only need the type of the field, without Q
 365                     fields' <- mapM (\(_, qt, _) ->
 366                                          qt >>= \t -> return (NotStrict, t))
 367                                fields
 368                     return $ NormalC (mkName cname) fields')
 369             cons
 370   let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq]
 371
 372   (savesig, savefn) <- genSaveOpCode cons
 373   (loadsig, loadfn) <- genLoadOpCode cons
 374   return [declD, loadsig, loadfn, savesig, savefn]
 375
 376 -- | Checks whether a given parameter is options.
 377 --
 378 -- This requires that it's a 'Maybe'.
 379 isOptional :: Type -> Bool
 380 isOptional (AppT (ConT dt) _) | dt == ''Maybe = True
 381 isOptional _ = False
 382
 383 -- | Generates the \"save\" expression for a single opcode parameter.
 384 --
 385 -- There is only one special handling mode: if the parameter is of
 386 -- 'Maybe' type, then we only save it if it's a 'Just' value,
 387 -- otherwise we skip it.
 388 saveField :: Name    -- ^ The name of variable that contains the value
 389           -> OpParam -- ^ Parameter definition
 390           -> Q Exp
 391 saveField fvar (fname, qt, _) = do
 392   t <- qt
 393   let fnexp = stringE fname
 394       fvare = varE fvar
 395   (if isOptional t
 396    then [| case $fvare of
 397              Just v' -> [( $fnexp, $showJSONE v')]
 398              Nothing -> []
 399          |]
 400    else [| [( $fnexp, $showJSONE $fvare )] |])
 401
 402 -- | Generates the \"save\" clause for an entire opcode constructor.
 403 --
 404 -- This matches the opcode with variables named the same as the
 405 -- constructor fields (just so that the spliced in code looks nicer),
 406 -- and passes those name plus the parameter definition to 'saveField'.
 407 saveConstructor :: String    -- ^ The constructor name
 408                 -> [OpParam] -- ^ The parameter definitions for this
 409                              -- constructor
 410                 -> Q Clause  -- ^ Resulting clause
 411 saveConstructor sname fields = do
 412   let cname = mkName sname
 413   let fnames = map (\(n, _, _) -> mkName n) fields
 414   let pat = conP cname (map varP fnames)
 415   let felems = map (uncurry saveField) (zip fnames fields)
 416       -- now build the OP_ID serialisation
 417       opid = [| [( $(stringE "OP_ID"),
 418                    $showJSONE $(stringE . deCamelCase $ sname) )] |]
 419       flist = listE (opid:felems)
 420       -- and finally convert all this to a json object
 421       flist' = [| $(varNameE "makeObj") (concat $flist) |]
 422   clause [pat] (normalB flist') []
 423
 424 -- | Generates the main save opcode function.
 425 --
 426 -- This builds a per-constructor match clause that contains the
 427 -- respective constructor-serialisation code.
 428 genSaveOpCode :: [(String, [OpParam])] -> Q (Dec, Dec)
 429 genSaveOpCode opdefs = do
 430   cclauses <- mapM (uncurry saveConstructor) opdefs
 431   let fname = mkName "saveOpCode"
 432   sigt <- [t| $(conT (mkName "OpCode")) -> JSON.JSValue |]
 433   return $ (SigD fname sigt, FunD fname cclauses)
 434
 435 -- | Generates the \"load\" field for a single parameter.
 436 --
 437 -- There is custom handling, depending on how the parameter is
 438 -- specified. For a 'Maybe' type parameter, we allow that it is not
 439 -- present (via 'Utils.maybeFromObj'). Otherwise, if there is a
 440 -- default value, we allow the parameter to be abset, and finally if
 441 -- there is no default value, we require its presence.
 442 loadField :: OpParam -> Q (Name, Stmt)
 443 loadField (fname, qt, qdefa) = do
 444   let fvar = mkName fname
 445   t <- qt
 446   defa <- qdefa
 447   -- these are used in all patterns below
 448   let objvar = varNameE "o"
 449       objfield = stringE fname
 450   bexp <- if isOptional t
 451           then [| $((varNameE "maybeFromObj")) $objvar $objfield |]
 452           else case defa of
 453                  AppE (ConE dt) defval | dt == 'Just ->
 454                    -- but has a default value
 455                    [| $(varNameE "fromObjWithDefault")
 456                       $objvar $objfield $(return defval) |]
 457                  ConE dt | dt == 'Nothing ->
 458                      [| $(varNameE "fromObj") $objvar $objfield |]
 459                  s -> fail $ "Invalid default value " ++ show s ++
 460                       ", expecting either 'Nothing' or a 'Just defval'"
 461   return (fvar, BindS (VarP fvar) bexp)
 462
 463 loadConstructor :: String -> [OpParam] -> Q Exp
 464 loadConstructor sname fields = do
 465   let name = mkName sname
 466   fbinds <- mapM loadField fields
 467   let (fnames, fstmts) = unzip fbinds
 468   let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
 469       fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
 470   return $ DoE fstmts'
 471
 472 genLoadOpCode :: [(String, [OpParam])] -> Q (Dec, Dec)
 473 genLoadOpCode opdefs = do
 474   let fname = mkName "loadOpCode"
 475       arg1 = mkName "v"
 476       objname = mkName "o"
 477       opid = mkName "op_id"
 478   st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
 479                                  (JSON.readJSON $(varE arg1)) |]
 480   st2 <- bindS (varP opid) [| $(varNameE "fromObj")
 481                               $(varE objname) $(stringE "OP_ID") |]
 482   -- the match results (per-constructor blocks)
 483   mexps <- mapM (uncurry loadConstructor) opdefs
 484   fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |]
 485   let mpats = map (\(me, c) ->
 486                        let mp = LitP . StringL . deCamelCase . fst $ c
 487                        in Match mp (NormalB me) []
 488                   ) $ zip mexps opdefs
 489       defmatch = Match WildP (NormalB fails) []
 490       cst = NoBindS $ CaseE (VarE opid) $ mpats++[defmatch]
 491       body = DoE [st1, st2, cst]
 492   sigt <- [t| JSON.JSValue -> JSON.Result $(conT (mkName "OpCode")) |]
 493   return $ (SigD fname sigt, FunD fname [Clause [VarP arg1] (NormalB body) []])
 494
 495 -- | No default type.
 496 noDefault :: Q Exp
 497 noDefault = conE 'Nothing
 498
 499 -- * Template code for luxi
 500
 501 -- | Constructor-to-string for LuxiOp.
 502 genStrOfOp :: Name -> String -> Q [Dec]
 503 genStrOfOp = genConstrToStr id
 504
 505 -- | Constructor-to-string for MsgKeys.
 506 genStrOfKey :: Name -> String -> Q [Dec]
 507 genStrOfKey = genConstrToStr ensureLower
 508
 509 -- | LuxiOp parameter type.
 510 type LuxiParam = (String, Q Type, Q Exp)
 511
 512 -- | Generates the LuxiOp data type.
 513 --
 514 -- This takes a Luxi operation definition and builds both the
 515 -- datatype and the function trnasforming the arguments to JSON.
 516 -- We can't use anything less generic, because the way different
 517 -- operations are serialized differs on both parameter- and top-level.
 518 --
 519 -- There are three things to be defined for each parameter:
 520 --
 521 -- * name
 522 --
 523 -- * type
 524 --
 525 -- * operation; this is the operation performed on the parameter before
 526 --   serialization
 527 --
 528 genLuxiOp :: String -> [(String, [LuxiParam])] -> Q [Dec]
 529 genLuxiOp name cons = do
 530   decl_d <- mapM (\(cname, fields) -> do
 531                     fields' <- mapM (\(_, qt, _) ->
 532                                          qt >>= \t -> return (NotStrict, t))
 533                                fields
 534                     return $ NormalC (mkName cname) fields')
 535             cons
 536   let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read]
 537   (savesig, savefn) <- genSaveLuxiOp cons
 538   return [declD, savesig, savefn]
 539
 540 -- | Generates the \"save\" expression for a single luxi parameter.
 541 saveLuxiField :: Name -> LuxiParam -> Q Exp
 542 saveLuxiField fvar (_, qt, fn) =
 543     [| JSON.showJSON ( $(liftM2 appFn fn $ varE fvar) ) |]
 544
 545 -- | Generates the \"save\" clause for entire LuxiOp constructor.
 546 saveLuxiConstructor :: (String, [LuxiParam]) -> Q Clause
 547 saveLuxiConstructor (sname, fields) = do
 548   let cname = mkName sname
 549       fnames = map (\(nm, _, _) -> mkName nm) fields
 550       pat = conP cname (map varP fnames)
 551       flist = map (uncurry saveLuxiField) (zip fnames fields)
 552       finval = if null flist
 553                then [| JSON.showJSON ()    |]
 554                else [| JSON.showJSON $(listE flist) |]
 555   clause [pat] (normalB finval) []
 556
 557 -- | Generates the main save LuxiOp function.
 558 genSaveLuxiOp :: [(String, [LuxiParam])]-> Q (Dec, Dec)
 559 genSaveLuxiOp opdefs = do
 560   sigt <- [t| $(conT (mkName "LuxiOp")) -> JSON.JSValue |]
 561   let fname = mkName "opToArgs"
 562   cclauses <- mapM saveLuxiConstructor opdefs
 563   return $ (SigD fname sigt, FunD fname cclauses)