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

   1 {-# LANGUAGE TemplateHaskell #-}
   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, 2012 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                   , genAllOpIDs
  37                   , genOpCode
  38                   , genStrOfOp
  39                   , genStrOfKey
  40                   , genLuxiOp
  41                   , Field
  42                   , simpleField
  43                   , defaultField
  44                   , optionalField
  45                   , renameField
  46                   , customField
  47                   , timeStampFields
  48                   , uuidFields
  49                   , serialFields
  50                   , tagsFields
  51                   , buildObject
  52                   , buildObjectSerialisation
  53                   , buildParam
  54                   ) where
  55
  56 import Control.Monad (liftM)
  57 import Data.Char
  58 import Data.List
  59 import Data.Maybe (fromMaybe)
  60 import qualified Data.Set as Set
  61 import Language.Haskell.TH
  62
  63 import qualified Text.JSON as JSON
  64
  65 -- * Exported types
  66
  67 -- | Serialised field data type.
  68 data Field = Field { fieldName        :: String
  69                    , fieldType        :: Q Type
  70                    , fieldRead        :: Maybe (Q Exp)
  71                    , fieldShow        :: Maybe (Q Exp)
  72                    , fieldDefault     :: Maybe (Q Exp)
  73                    , fieldConstr      :: Maybe String
  74                    , fieldIsOptional  :: Bool
  75                    }
  76
  77 -- | Generates a simple field.
  78 simpleField :: String -> Q Type -> Field
  79 simpleField fname ftype =
  80   Field { fieldName        = fname
  81         , fieldType        = ftype
  82         , fieldRead        = Nothing
  83         , fieldShow        = Nothing
  84         , fieldDefault     = Nothing
  85         , fieldConstr      = Nothing
  86         , fieldIsOptional  = False
  87         }
  88
  89 -- | Sets the renamed constructor field.
  90 renameField :: String -> Field -> Field
  91 renameField constrName field = field { fieldConstr = Just constrName }
  92
  93 -- | Sets the default value on a field (makes it optional with a
  94 -- default value).
  95 defaultField :: Q Exp -> Field -> Field
  96 defaultField defval field = field { fieldDefault = Just defval }
  97
  98 -- | Marks a field optional (turning its base type into a Maybe).
  99 optionalField :: Field -> Field
 100 optionalField field = field { fieldIsOptional = True }
 101
 102 -- | Sets custom functions on a field.
 103 customField :: Name    -- ^ The name of the read function
 104             -> Name    -- ^ The name of the show function
 105             -> Field   -- ^ The original field
 106             -> Field   -- ^ Updated field
 107 customField readfn showfn field =
 108   field { fieldRead = Just (varE readfn), fieldShow = Just (varE showfn) }
 109
 110 -- | Computes the record name for a given field, based on either the
 111 -- string value in the JSON serialisation or the custom named if any
 112 -- exists.
 113 fieldRecordName :: Field -> String
 114 fieldRecordName (Field { fieldName = name, fieldConstr = alias }) =
 115   fromMaybe (camelCase name) alias
 116
 117 -- | Computes the preferred variable name to use for the value of this
 118 -- field. If the field has a specific constructor name, then we use a
 119 -- first-letter-lowercased version of that; otherwise, we simply use
 120 -- the field name. See also 'fieldRecordName'.
 121 fieldVariable :: Field -> String
 122 fieldVariable f =
 123   case (fieldConstr f) of
 124     Just name -> ensureLower name
 125     _ -> map (\c -> if c == '-' then '_' else c) $ fieldName f
 126
 127 actualFieldType :: Field -> Q Type
 128 actualFieldType f | fieldIsOptional f  = [t| Maybe $t     |]
 129                   | otherwise = t
 130                   where t = fieldType f
 131
 132 checkNonOptDef :: (Monad m) => Field -> m ()
 133 checkNonOptDef (Field { fieldIsOptional = True, fieldName = name }) =
 134   fail $ "Optional field " ++ name ++ " used in parameter declaration"
 135 checkNonOptDef (Field { fieldDefault = (Just _), fieldName = name }) =
 136   fail $ "Default field " ++ name ++ " used in parameter declaration"
 137 checkNonOptDef _ = return ()
 138
 139 -- | Produces the expression that will de-serialise a given
 140 -- field. Since some custom parsing functions might need to use the
 141 -- entire object, we do take and pass the object to any custom read
 142 -- functions.
 143 loadFn :: Field   -- ^ The field definition
 144        -> Q Exp   -- ^ The value of the field as existing in the JSON message
 145        -> Q Exp   -- ^ The entire object in JSON object format
 146        -> Q Exp   -- ^ Resulting expression
 147 loadFn (Field { fieldRead = Just readfn }) expr o = [| $expr >>= $readfn $o |]
 148 loadFn _ expr _ = expr
 149
 150 -- * Common field declarations
 151
 152 -- | Timestamp fields description.
 153 timeStampFields :: [Field]
 154 timeStampFields =
 155     [ defaultField [| 0::Double |] $ simpleField "ctime" [t| Double |]
 156     , defaultField [| 0::Double |] $ simpleField "mtime" [t| Double |]
 157     ]
 158
 159 -- | Serial number fields description.
 160 serialFields :: [Field]
 161 serialFields =
 162     [ renameField  "Serial" $ simpleField "serial_no" [t| Int |] ]
 163
 164 -- | UUID fields description.
 165 uuidFields :: [Field]
 166 uuidFields = [ simpleField "uuid" [t| String |] ]
 167
 168 -- | Tag field description.
 169 tagsFields :: [Field]
 170 tagsFields = [ defaultField [| Set.empty |] $
 171                simpleField "tags" [t| Set.Set String |] ]
 172
 173 -- * Helper functions
 174
 175 -- | Ensure first letter is lowercase.
 176 --
 177 -- Used to convert type name to function prefix, e.g. in @data Aa ->
 178 -- aaToRaw@.
 179 ensureLower :: String -> String
 180 ensureLower [] = []
 181 ensureLower (x:xs) = toLower x:xs
 182
 183 -- | Ensure first letter is uppercase.
 184 --
 185 -- Used to convert constructor name to component
 186 ensureUpper :: String -> String
 187 ensureUpper [] = []
 188 ensureUpper (x:xs) = toUpper x:xs
 189
 190 -- | Helper for quoted expressions.
 191 varNameE :: String -> Q Exp
 192 varNameE = varE . mkName
 193
 194 -- | showJSON as an expression, for reuse.
 195 showJSONE :: Q Exp
 196 showJSONE = varNameE "showJSON"
 197
 198 -- | ToRaw function name.
 199 toRawName :: String -> Name
 200 toRawName = mkName . (++ "ToRaw") . ensureLower
 201
 202 -- | FromRaw function name.
 203 fromRawName :: String -> Name
 204 fromRawName = mkName . (++ "FromRaw") . ensureLower
 205
 206 -- | Converts a name to it's varE\/litE representations.
 207 reprE :: Either String Name -> Q Exp
 208 reprE = either stringE varE
 209
 210 -- | Smarter function application.
 211 --
 212 -- This does simply f x, except that if is 'id', it will skip it, in
 213 -- order to generate more readable code when using -ddump-splices.
 214 appFn :: Exp -> Exp -> Exp
 215 appFn f x | f == VarE 'id = x
 216           | otherwise = AppE f x
 217
 218 -- * Template code for simple raw type-equivalent ADTs
 219
 220 -- | Generates a data type declaration.
 221 --
 222 -- The type will have a fixed list of instances.
 223 strADTDecl :: Name -> [String] -> Dec
 224 strADTDecl name constructors =
 225   DataD [] name []
 226           (map (flip NormalC [] . mkName) constructors)
 227           [''Show, ''Read, ''Eq, ''Enum, ''Bounded, ''Ord]
 228
 229 -- | Generates a toRaw function.
 230 --
 231 -- This generates a simple function of the form:
 232 --
 233 -- @
 234 -- nameToRaw :: Name -> /traw/
 235 -- nameToRaw Cons1 = var1
 236 -- nameToRaw Cons2 = \"value2\"
 237 -- @
 238 genToRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec]
 239 genToRaw traw fname tname constructors = do
 240   let sigt = AppT (AppT ArrowT (ConT tname)) (ConT traw)
 241   -- the body clauses, matching on the constructor and returning the
 242   -- raw value
 243   clauses <- mapM  (\(c, v) -> clause [recP (mkName c) []]
 244                              (normalB (reprE v)) []) constructors
 245   return [SigD fname sigt, FunD fname clauses]
 246
 247 -- | Generates a fromRaw function.
 248 --
 249 -- The function generated is monadic and can fail parsing the
 250 -- raw value. It is of the form:
 251 --
 252 -- @
 253 -- nameFromRaw :: (Monad m) => /traw/ -> m Name
 254 -- nameFromRaw s | s == var1       = Cons1
 255 --               | s == \"value2\" = Cons2
 256 --               | otherwise = fail /.../
 257 -- @
 258 genFromRaw :: Name -> Name -> Name -> [(String, Name)] -> Q [Dec]
 259 genFromRaw traw fname tname constructors = do
 260   -- signature of form (Monad m) => String -> m $name
 261   sigt <- [t| (Monad m) => $(conT traw) -> m $(conT tname) |]
 262   -- clauses for a guarded pattern
 263   let varp = mkName "s"
 264       varpe = varE varp
 265   clauses <- mapM (\(c, v) -> do
 266                      -- the clause match condition
 267                      g <- normalG [| $varpe == $(varE v) |]
 268                      -- the clause result
 269                      r <- [| return $(conE (mkName c)) |]
 270                      return (g, r)) constructors
 271   -- the otherwise clause (fallback)
 272   oth_clause <- do
 273     g <- normalG [| otherwise |]
 274     r <- [|fail ("Invalid string value for type " ++
 275                  $(litE (stringL (nameBase tname))) ++ ": " ++ show $varpe) |]
 276     return (g, r)
 277   let fun = FunD fname [Clause [VarP varp]
 278                         (GuardedB (clauses++[oth_clause])) []]
 279   return [SigD fname sigt, fun]
 280
 281 -- | Generates a data type from a given raw format.
 282 --
 283 -- The format is expected to multiline. The first line contains the
 284 -- type name, and the rest of the lines must contain two words: the
 285 -- constructor name and then the string representation of the
 286 -- respective constructor.
 287 --
 288 -- The function will generate the data type declaration, and then two
 289 -- functions:
 290 --
 291 -- * /name/ToRaw, which converts the type to a raw type
 292 --
 293 -- * /name/FromRaw, which (monadically) converts from a raw type to the type
 294 --
 295 -- Note that this is basically just a custom show\/read instance,
 296 -- nothing else.
 297 declareADT :: Name -> String -> [(String, Name)] -> Q [Dec]
 298 declareADT traw sname cons = do
 299   let name = mkName sname
 300       ddecl = strADTDecl name (map fst cons)
 301       -- process cons in the format expected by genToRaw
 302       cons' = map (\(a, b) -> (a, Right b)) cons
 303   toraw <- genToRaw traw (toRawName sname) name cons'
 304   fromraw <- genFromRaw traw (fromRawName sname) name cons
 305   return $ ddecl:toraw ++ fromraw
 306
 307 declareIADT :: String -> [(String, Name)] -> Q [Dec]
 308 declareIADT = declareADT ''Int
 309
 310 declareSADT :: String -> [(String, Name)] -> Q [Dec]
 311 declareSADT = declareADT ''String
 312
 313 -- | Creates the showJSON member of a JSON instance declaration.
 314 --
 315 -- This will create what is the equivalent of:
 316 --
 317 -- @
 318 -- showJSON = showJSON . /name/ToRaw
 319 -- @
 320 --
 321 -- in an instance JSON /name/ declaration
 322 genShowJSON :: String -> Q Dec
 323 genShowJSON name = do
 324   body <- [| JSON.showJSON . $(varE (toRawName name)) |]
 325   return $ FunD (mkName "showJSON") [Clause [] (NormalB body) []]
 326
 327 -- | Creates the readJSON member of a JSON instance declaration.
 328 --
 329 -- This will create what is the equivalent of:
 330 --
 331 -- @
 332 -- readJSON s = case readJSON s of
 333 --                Ok s' -> /name/FromRaw s'
 334 --                Error e -> Error /description/
 335 -- @
 336 --
 337 -- in an instance JSON /name/ declaration
 338 genReadJSON :: String -> Q Dec
 339 genReadJSON name = do
 340   let s = mkName "s"
 341   body <- [| case JSON.readJSON $(varE s) of
 342                JSON.Ok s' -> $(varE (fromRawName name)) s'
 343                JSON.Error e ->
 344                    JSON.Error $ "Can't parse raw value for type " ++
 345                            $(stringE name) ++ ": " ++ e ++ " from " ++
 346                            show $(varE s)
 347            |]
 348   return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []]
 349
 350 -- | Generates a JSON instance for a given type.
 351 --
 352 -- This assumes that the /name/ToRaw and /name/FromRaw functions
 353 -- have been defined as by the 'declareSADT' function.
 354 makeJSONInstance :: Name -> Q [Dec]
 355 makeJSONInstance name = do
 356   let base = nameBase name
 357   showJ <- genShowJSON base
 358   readJ <- genReadJSON base
 359   return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) [readJ,showJ]]
 360
 361 -- * Template code for opcodes
 362
 363 -- | Transforms a CamelCase string into an_underscore_based_one.
 364 deCamelCase :: String -> String
 365 deCamelCase =
 366     intercalate "_" . map (map toUpper) . groupBy (\_ b -> not $ isUpper b)
 367
 368 -- | Transform an underscore_name into a CamelCase one.
 369 camelCase :: String -> String
 370 camelCase = concatMap (ensureUpper . drop 1) .
 371             groupBy (\_ b -> b /= '_' && b /= '-') . ('_':)
 372
 373 -- | Computes the name of a given constructor.
 374 constructorName :: Con -> Q Name
 375 constructorName (NormalC name _) = return name
 376 constructorName (RecC name _)    = return name
 377 constructorName x                = fail $ "Unhandled constructor " ++ show x
 378
 379 -- | Extract all constructor names from a given type.
 380 reifyConsNames :: Name -> Q [String]
 381 reifyConsNames name = do
 382   reify_result <- reify name
 383   case reify_result of
 384     TyConI (DataD _ _ _ cons _) -> mapM (liftM nameBase . constructorName) cons
 385     o -> fail $ "Unhandled name passed to reifyConsNames, expected\
 386                 \ type constructor but got '" ++ show o ++ "'"
 387
 388 -- | Builds the generic constructor-to-string function.
 389 --
 390 -- This generates a simple function of the following form:
 391 --
 392 -- @
 393 -- fname (ConStructorOne {}) = trans_fun("ConStructorOne")
 394 -- fname (ConStructorTwo {}) = trans_fun("ConStructorTwo")
 395 -- @
 396 --
 397 -- This builds a custom list of name\/string pairs and then uses
 398 -- 'genToRaw' to actually generate the function.
 399 genConstrToStr :: (String -> String) -> Name -> String -> Q [Dec]
 400 genConstrToStr trans_fun name fname = do
 401   cnames <- reifyConsNames name
 402   let svalues = map (Left . trans_fun) cnames
 403   genToRaw ''String (mkName fname) name $ zip cnames svalues
 404
 405 -- | Constructor-to-string for OpCode.
 406 genOpID :: Name -> String -> Q [Dec]
 407 genOpID = genConstrToStr deCamelCase
 408
 409 -- | Builds a list with all defined constructor names for a type.
 410 --
 411 -- @
 412 -- vstr :: String
 413 -- vstr = [...]
 414 -- @
 415 --
 416 -- Where the actual values of the string are the constructor names
 417 -- mapped via @trans_fun@.
 418 genAllConstr :: (String -> String) -> Name -> String -> Q [Dec]
 419 genAllConstr trans_fun name vstr = do
 420   cnames <- reifyConsNames name
 421   let svalues = sort $ map trans_fun cnames
 422       vname = mkName vstr
 423       sig = SigD vname (AppT ListT (ConT ''String))
 424       body = NormalB (ListE (map (LitE . StringL) svalues))
 425   return $ [sig, ValD (VarP vname) body []]
 426
 427 -- | Generates a list of all defined opcode IDs.
 428 genAllOpIDs :: Name -> String -> Q [Dec]
 429 genAllOpIDs = genAllConstr deCamelCase
 430
 431 -- | OpCode parameter (field) type.
 432 type OpParam = (String, Q Type, Q Exp)
 433
 434 -- | Generates the OpCode data type.
 435 --
 436 -- This takes an opcode logical definition, and builds both the
 437 -- datatype and the JSON serialisation out of it. We can't use a
 438 -- generic serialisation since we need to be compatible with Ganeti's
 439 -- own, so we have a few quirks to work around.
 440 genOpCode :: String                -- ^ Type name to use
 441           -> [(String, [Field])]   -- ^ Constructor name and parameters
 442           -> Q [Dec]
 443 genOpCode name cons = do
 444   decl_d <- mapM (\(cname, fields) -> do
 445                     -- we only need the type of the field, without Q
 446                     fields' <- mapM actualFieldType fields
 447                     let fields'' = zip (repeat NotStrict) fields'
 448                     return $ NormalC (mkName cname) fields'')
 449             cons
 450   let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq]
 451
 452   (savesig, savefn) <- genSaveOpCode cons
 453   (loadsig, loadfn) <- genLoadOpCode cons
 454   return [declD, loadsig, loadfn, savesig, savefn]
 455
 456 -- | Checks whether a given parameter is options.
 457 --
 458 -- This requires that it's a 'Maybe'.
 459 isOptional :: Type -> Bool
 460 isOptional (AppT (ConT dt) _) | dt == ''Maybe = True
 461 isOptional _ = False
 462
 463 -- | Generates the \"save\" clause for an entire opcode constructor.
 464 --
 465 -- This matches the opcode with variables named the same as the
 466 -- constructor fields (just so that the spliced in code looks nicer),
 467 -- and passes those name plus the parameter definition to 'saveObjectField'.
 468 saveConstructor :: String    -- ^ The constructor name
 469                 -> [Field]   -- ^ The parameter definitions for this
 470                              -- constructor
 471                 -> Q Clause  -- ^ Resulting clause
 472 saveConstructor sname fields = do
 473   let cname = mkName sname
 474   fnames <- mapM (newName . fieldVariable) fields
 475   let pat = conP cname (map varP fnames)
 476   let felems = map (uncurry saveObjectField) (zip fnames fields)
 477       -- now build the OP_ID serialisation
 478       opid = [| [( $(stringE "OP_ID"),
 479                    JSON.showJSON $(stringE . deCamelCase $ sname) )] |]
 480       flist = listE (opid:felems)
 481       -- and finally convert all this to a json object
 482       flist' = [| $(varNameE "makeObj") (concat $flist) |]
 483   clause [pat] (normalB flist') []
 484
 485 -- | Generates the main save opcode function.
 486 --
 487 -- This builds a per-constructor match clause that contains the
 488 -- respective constructor-serialisation code.
 489 genSaveOpCode :: [(String, [Field])] -> Q (Dec, Dec)
 490 genSaveOpCode opdefs = do
 491   cclauses <- mapM (uncurry saveConstructor) opdefs
 492   let fname = mkName "saveOpCode"
 493   sigt <- [t| $(conT (mkName "OpCode")) -> JSON.JSValue |]
 494   return $ (SigD fname sigt, FunD fname cclauses)
 495
 496 -- | Generates load code for a single constructor of the opcode data type.
 497 loadConstructor :: String -> [Field] -> Q Exp
 498 loadConstructor sname fields = do
 499   let name = mkName sname
 500   fbinds <- mapM loadObjectField fields
 501   let (fnames, fstmts) = unzip fbinds
 502   let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
 503       fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
 504   return $ DoE fstmts'
 505
 506 -- | Generates the loadOpCode function.
 507 genLoadOpCode :: [(String, [Field])] -> Q (Dec, Dec)
 508 genLoadOpCode opdefs = do
 509   let fname = mkName "loadOpCode"
 510       arg1 = mkName "v"
 511       objname = mkName "o"
 512       opid = mkName "op_id"
 513   st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
 514                                  (JSON.readJSON $(varE arg1)) |]
 515   st2 <- bindS (varP opid) [| $(varNameE "fromObj")
 516                               $(varE objname) $(stringE "OP_ID") |]
 517   -- the match results (per-constructor blocks)
 518   mexps <- mapM (uncurry loadConstructor) opdefs
 519   fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |]
 520   let mpats = map (\(me, c) ->
 521                        let mp = LitP . StringL . deCamelCase . fst $ c
 522                        in Match mp (NormalB me) []
 523                   ) $ zip mexps opdefs
 524       defmatch = Match WildP (NormalB fails) []
 525       cst = NoBindS $ CaseE (VarE opid) $ mpats++[defmatch]
 526       body = DoE [st1, st2, cst]
 527   sigt <- [t| JSON.JSValue -> JSON.Result $(conT (mkName "OpCode")) |]
 528   return $ (SigD fname sigt, FunD fname [Clause [VarP arg1] (NormalB body) []])
 529
 530 -- * Template code for luxi
 531
 532 -- | Constructor-to-string for LuxiOp.
 533 genStrOfOp :: Name -> String -> Q [Dec]
 534 genStrOfOp = genConstrToStr id
 535
 536 -- | Constructor-to-string for MsgKeys.
 537 genStrOfKey :: Name -> String -> Q [Dec]
 538 genStrOfKey = genConstrToStr ensureLower
 539
 540 -- | LuxiOp parameter type.
 541 type LuxiParam = (String, Q Type)
 542
 543 -- | Generates the LuxiOp data type.
 544 --
 545 -- This takes a Luxi operation definition and builds both the
 546 -- datatype and the function trnasforming the arguments to JSON.
 547 -- We can't use anything less generic, because the way different
 548 -- operations are serialized differs on both parameter- and top-level.
 549 --
 550 -- There are two things to be defined for each parameter:
 551 --
 552 -- * name
 553 --
 554 -- * type
 555 --
 556 genLuxiOp :: String -> [(String, [LuxiParam])] -> Q [Dec]
 557 genLuxiOp name cons = do
 558   decl_d <- mapM (\(cname, fields) -> do
 559                     fields' <- mapM (\(_, qt) ->
 560                                          qt >>= \t -> return (NotStrict, t))
 561                                fields
 562                     return $ NormalC (mkName cname) fields')
 563             cons
 564   let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq]
 565   (savesig, savefn) <- genSaveLuxiOp cons
 566   req_defs <- declareSADT "LuxiReq" .
 567               map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $
 568                   cons
 569   return $ [declD, savesig, savefn] ++ req_defs
 570
 571 -- | Generates the \"save\" expression for a single luxi parameter.
 572 saveLuxiField :: Name -> LuxiParam -> Q Exp
 573 saveLuxiField fvar (_, qt) =
 574     [| JSON.showJSON $(varE fvar) |]
 575
 576 -- | Generates the \"save\" clause for entire LuxiOp constructor.
 577 saveLuxiConstructor :: (String, [LuxiParam]) -> Q Clause
 578 saveLuxiConstructor (sname, fields) = do
 579   let cname = mkName sname
 580       fnames = map (mkName . fst) fields
 581       pat = conP cname (map varP fnames)
 582       flist = map (uncurry saveLuxiField) (zip fnames fields)
 583       finval = if null flist
 584                then [| JSON.showJSON ()    |]
 585                else [| JSON.showJSON $(listE flist) |]
 586   clause [pat] (normalB finval) []
 587
 588 -- | Generates the main save LuxiOp function.
 589 genSaveLuxiOp :: [(String, [LuxiParam])]-> Q (Dec, Dec)
 590 genSaveLuxiOp opdefs = do
 591   sigt <- [t| $(conT (mkName "LuxiOp")) -> JSON.JSValue |]
 592   let fname = mkName "opToArgs"
 593   cclauses <- mapM saveLuxiConstructor opdefs
 594   return $ (SigD fname sigt, FunD fname cclauses)
 595
 596 -- * "Objects" functionality
 597
 598 -- | Extract the field's declaration from a Field structure.
 599 fieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
 600 fieldTypeInfo field_pfx fd = do
 601   t <- actualFieldType fd
 602   let n = mkName . (field_pfx ++) . fieldRecordName $ fd
 603   return (n, NotStrict, t)
 604
 605 -- | Build an object declaration.
 606 buildObject :: String -> String -> [Field] -> Q [Dec]
 607 buildObject sname field_pfx fields = do
 608   let name = mkName sname
 609   fields_d <- mapM (fieldTypeInfo field_pfx) fields
 610   let decl_d = RecC name fields_d
 611   let declD = DataD [] name [] [decl_d] [''Show, ''Read, ''Eq]
 612   ser_decls <- buildObjectSerialisation sname fields
 613   return $ declD:ser_decls
 614
 615 -- | Generates an object definition: data type and its JSON instance.
 616 buildObjectSerialisation :: String -> [Field] -> Q [Dec]
 617 buildObjectSerialisation sname fields = do
 618   let name = mkName sname
 619   savedecls <- genSaveObject saveObjectField sname fields
 620   (loadsig, loadfn) <- genLoadObject loadObjectField sname fields
 621   shjson <- objectShowJSON sname
 622   rdjson <- objectReadJSON sname
 623   let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
 624                  [rdjson, shjson]
 625   return $ savedecls ++ [loadsig, loadfn, instdecl]
 626
 627 -- | Generates the save object functionality.
 628 genSaveObject :: (Name -> Field -> Q Exp)
 629               -> String -> [Field] -> Q [Dec]
 630 genSaveObject save_fn sname fields = do
 631   let name = mkName sname
 632   fnames <- mapM (newName . fieldVariable) fields
 633   let pat = conP name (map varP fnames)
 634   let tdname = mkName ("toDict" ++ sname)
 635   tdsigt <- [t| $(conT name) -> [(String, JSON.JSValue)] |]
 636
 637   let felems = map (uncurry save_fn) (zip fnames fields)
 638       flist = listE felems
 639       -- and finally convert all this to a json object
 640       tdlist = [| concat $flist |]
 641       iname = mkName "i"
 642   tclause <- clause [pat] (normalB tdlist) []
 643   cclause <- [| $(varNameE "makeObj") . $(varE tdname) |]
 644   let fname = mkName ("save" ++ sname)
 645   sigt <- [t| $(conT name) -> JSON.JSValue |]
 646   return [SigD tdname tdsigt, FunD tdname [tclause],
 647           SigD fname sigt, ValD (VarP fname) (NormalB cclause) []]
 648
 649 -- | Generates the code for saving an object's field, handling the
 650 -- various types of fields that we have.
 651 saveObjectField :: Name -> Field -> Q Exp
 652 saveObjectField fvar field
 653   | fisOptional = [| case $(varE fvar) of
 654                       Nothing -> []
 655                       Just v -> [( $nameE, JSON.showJSON v)]
 656                   |]
 657   | otherwise = case fieldShow field of
 658       Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |]
 659       Just fn -> [| let (actual, extra) = $fn $fvarE
 660                     in extra ++ [( $nameE, JSON.showJSON actual)]
 661                   |]
 662   where fisOptional  = fieldIsOptional field
 663         nameE = stringE (fieldName field)
 664         fvarE = varE fvar
 665
 666 -- | Generates the showJSON clause for a given object name.
 667 objectShowJSON :: String -> Q Dec
 668 objectShowJSON name = do
 669   body <- [| JSON.showJSON . $(varE . mkName $ "save" ++ name) |]
 670   return $ FunD (mkName "showJSON") [Clause [] (NormalB body) []]
 671
 672 -- | Generates the load object functionality.
 673 genLoadObject :: (Field -> Q (Name, Stmt))
 674               -> String -> [Field] -> Q (Dec, Dec)
 675 genLoadObject load_fn sname fields = do
 676   let name = mkName sname
 677       funname = mkName $ "load" ++ sname
 678       arg1 = mkName "v"
 679       objname = mkName "o"
 680       opid = mkName "op_id"
 681   st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
 682                                  (JSON.readJSON $(varE arg1)) |]
 683   fbinds <- mapM load_fn fields
 684   let (fnames, fstmts) = unzip fbinds
 685   let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
 686       fstmts' = st1:fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
 687   sigt <- [t| JSON.JSValue -> JSON.Result $(conT name) |]
 688   return $ (SigD funname sigt,
 689             FunD funname [Clause [VarP arg1] (NormalB (DoE fstmts')) []])
 690
 691 -- | Generates code for loading an object's field.
 692 loadObjectField :: Field -> Q (Name, Stmt)
 693 loadObjectField field = do
 694   let name = fieldVariable field
 695   fvar <- newName name
 696   -- these are used in all patterns below
 697   let objvar = varNameE "o"
 698       objfield = stringE (fieldName field)
 699       loadexp =
 700         if fieldIsOptional field
 701           then [| $(varNameE "maybeFromObj") $objvar $objfield |]
 702           else case fieldDefault field of
 703                  Just defv ->
 704                    [| $(varNameE "fromObjWithDefault") $objvar
 705                       $objfield $defv |]
 706                  Nothing -> [| $(varNameE "fromObj") $objvar $objfield |]
 707   bexp <- loadFn field loadexp objvar
 708
 709   return (fvar, BindS (VarP fvar) bexp)
 710
 711 -- | Builds the readJSON instance for a given object name.
 712 objectReadJSON :: String -> Q Dec
 713 objectReadJSON name = do
 714   let s = mkName "s"
 715   body <- [| case JSON.readJSON $(varE s) of
 716                JSON.Ok s' -> $(varE .mkName $ "load" ++ name) s'
 717                JSON.Error e ->
 718                  JSON.Error $ "Can't parse value for type " ++
 719                        $(stringE name) ++ ": " ++ e
 720            |]
 721   return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []]
 722
 723 -- * Inheritable parameter tables implementation
 724
 725 -- | Compute parameter type names.
 726 paramTypeNames :: String -> (String, String)
 727 paramTypeNames root = ("Filled"  ++ root ++ "Params",
 728                        "Partial" ++ root ++ "Params")
 729
 730 -- | Compute information about the type of a parameter field.
 731 paramFieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
 732 paramFieldTypeInfo field_pfx fd = do
 733   t <- actualFieldType fd
 734   let n = mkName . (++ "P") . (field_pfx ++) .
 735           fieldRecordName $ fd
 736   return (n, NotStrict, AppT (ConT ''Maybe) t)
 737
 738 -- | Build a parameter declaration.
 739 --
 740 -- This function builds two different data structures: a /filled/ one,
 741 -- in which all fields are required, and a /partial/ one, in which all
 742 -- fields are optional. Due to the current record syntax issues, the
 743 -- fields need to be named differrently for the two structures, so the
 744 -- partial ones get a /P/ suffix.
 745 buildParam :: String -> String -> [Field] -> Q [Dec]
 746 buildParam sname field_pfx fields = do
 747   let (sname_f, sname_p) = paramTypeNames sname
 748       name_f = mkName sname_f
 749       name_p = mkName sname_p
 750   fields_f <- mapM (fieldTypeInfo field_pfx) fields
 751   fields_p <- mapM (paramFieldTypeInfo field_pfx) fields
 752   let decl_f = RecC name_f fields_f
 753       decl_p = RecC name_p fields_p
 754   let declF = DataD [] name_f [] [decl_f] [''Show, ''Read, ''Eq]
 755       declP = DataD [] name_p [] [decl_p] [''Show, ''Read, ''Eq]
 756   ser_decls_f <- buildObjectSerialisation sname_f fields
 757   ser_decls_p <- buildPParamSerialisation sname_p fields
 758   fill_decls <- fillParam sname field_pfx fields
 759   return $ [declF, declP] ++ ser_decls_f ++ ser_decls_p ++ fill_decls
 760
 761 -- | Generates the serialisation for a partial parameter.
 762 buildPParamSerialisation :: String -> [Field] -> Q [Dec]
 763 buildPParamSerialisation sname fields = do
 764   let name = mkName sname
 765   savedecls <- genSaveObject savePParamField sname fields
 766   (loadsig, loadfn) <- genLoadObject loadPParamField sname fields
 767   shjson <- objectShowJSON sname
 768   rdjson <- objectReadJSON sname
 769   let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
 770                  [rdjson, shjson]
 771   return $ savedecls ++ [loadsig, loadfn, instdecl]
 772
 773 -- | Generates code to save an optional parameter field.
 774 savePParamField :: Name -> Field -> Q Exp
 775 savePParamField fvar field = do
 776   checkNonOptDef field
 777   let actualVal = mkName "v"
 778   normalexpr <- saveObjectField actualVal field
 779   -- we have to construct the block here manually, because we can't
 780   -- splice-in-splice
 781   return $ CaseE (VarE fvar) [ Match (ConP 'Nothing [])
 782                                        (NormalB (ConE '[])) []
 783                              , Match (ConP 'Just [VarP actualVal])
 784                                        (NormalB normalexpr) []
 785                              ]
 786
 787 -- | Generates code to load an optional parameter field.
 788 loadPParamField :: Field -> Q (Name, Stmt)
 789 loadPParamField field = do
 790   checkNonOptDef field
 791   let name = fieldName field
 792   fvar <- newName name
 793   -- these are used in all patterns below
 794   let objvar = varNameE "o"
 795       objfield = stringE name
 796       loadexp = [| $(varNameE "maybeFromObj") $objvar $objfield |]
 797   bexp <- loadFn field loadexp objvar
 798   return (fvar, BindS (VarP fvar) bexp)
 799
 800 -- | Builds a simple declaration of type @n_x = fromMaybe f_x p_x@.
 801 buildFromMaybe :: String -> Q Dec
 802 buildFromMaybe fname =
 803   valD (varP (mkName $ "n_" ++ fname))
 804          (normalB [| $(varNameE "fromMaybe")
 805                         $(varNameE $ "f_" ++ fname)
 806                         $(varNameE $ "p_" ++ fname) |]) []
 807
 808 -- | Builds a function that executes the filling of partial parameter
 809 -- from a full copy (similar to Python's fillDict).
 810 fillParam :: String -> String -> [Field] -> Q [Dec]
 811 fillParam sname field_pfx fields = do
 812   let fnames = map (\fd -> field_pfx ++ fieldRecordName fd) fields
 813       (sname_f, sname_p) = paramTypeNames sname
 814       oname_f = "fobj"
 815       oname_p = "pobj"
 816       name_f = mkName sname_f
 817       name_p = mkName sname_p
 818       fun_name = mkName $ "fill" ++ sname ++ "Params"
 819       le_full = ValD (ConP name_f (map (VarP . mkName . ("f_" ++)) fnames))
 820                 (NormalB . VarE . mkName $ oname_f) []
 821       le_part = ValD (ConP name_p (map (VarP . mkName . ("p_" ++)) fnames))
 822                 (NormalB . VarE . mkName $ oname_p) []
 823       obj_new = foldl (\accu vname -> AppE accu (VarE vname)) (ConE name_f)
 824                 $ map (mkName . ("n_" ++)) fnames
 825   le_new <- mapM buildFromMaybe fnames
 826   funt <- [t| $(conT name_f) -> $(conT name_p) -> $(conT name_f) |]
 827   let sig = SigD fun_name funt
 828       fclause = Clause [VarP (mkName oname_f), VarP (mkName oname_p)]
 829                 (NormalB $ LetE (le_full:le_part:le_new) obj_new) []
 830       fun = FunD fun_name [fclause]
 831   return [sig, fun]