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