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