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