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