THH.hs 40.5 KB
Newer Older
1
{-# LANGUAGE TemplateHaskell #-}
2

3
{-| TemplateHaskell helper for Ganeti Haskell code.
4 5 6 7 8 9 10 11 12

As TemplateHaskell require that splices be defined in a separate
module, we combine all the TemplateHaskell functionality that HTools
needs in this module (except the one for unittests).

-}

{-

13
Copyright (C) 2011, 2012 Google Inc.
14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.

-}

32
module Ganeti.THH ( declareSADT
33
                  , declareIADT
34
                  , makeJSONInstance
35
                  , genOpID
36
                  , genAllConstr
37
                  , genAllOpIDs
38
                  , genOpCode
39 40 41
                  , genStrOfOp
                  , genStrOfKey
                  , genLuxiOp
42 43 44 45
                  , Field
                  , simpleField
                  , defaultField
                  , optionalField
46
                  , optionalNullSerField
47 48 49 50 51
                  , renameField
                  , customField
                  , timeStampFields
                  , uuidFields
                  , serialFields
Iustin Pop's avatar
Iustin Pop committed
52
                  , tagsFields
53
                  , TagSet
54 55 56
                  , buildObject
                  , buildObjectSerialisation
                  , buildParam
57
                  , DictObject(..)
58 59
                  , genException
                  , excErrMsg
60 61
                  ) where

62
import Control.Monad (liftM)
63
import Data.Char
64
import Data.List
65
import Data.Maybe (fromMaybe)
Iustin Pop's avatar
Iustin Pop committed
66
import qualified Data.Set as Set
67 68 69
import Language.Haskell.TH

import qualified Text.JSON as JSON
70
import Text.JSON.Pretty (pp_value)
71

72 73
import Ganeti.JSON

74 75
-- * Exported types

76 77 78 79 80
-- | Class of objects that can be converted to 'JSObject'
-- lists-format.
class DictObject a where
  toDict :: a -> [(String, JSON.JSValue)]

81 82 83 84 85 86 87
-- | Optional field information.
data OptionalType
  = NotOptional           -- ^ Field is not optional
  | OptionalOmitNull      -- ^ Field is optional, null is not serialised
  | OptionalSerializeNull -- ^ Field is optional, null is serialised
  deriving (Show, Eq)

88 89 90 91 92
-- | Serialised field data type.
data Field = Field { fieldName        :: String
                   , fieldType        :: Q Type
                   , fieldRead        :: Maybe (Q Exp)
                   , fieldShow        :: Maybe (Q Exp)
Iustin Pop's avatar
Iustin Pop committed
93
                   , fieldExtraKeys   :: [String]
94 95
                   , fieldDefault     :: Maybe (Q Exp)
                   , fieldConstr      :: Maybe String
96
                   , fieldIsOptional  :: OptionalType
97 98 99 100 101 102 103 104 105
                   }

-- | Generates a simple field.
simpleField :: String -> Q Type -> Field
simpleField fname ftype =
  Field { fieldName        = fname
        , fieldType        = ftype
        , fieldRead        = Nothing
        , fieldShow        = Nothing
Iustin Pop's avatar
Iustin Pop committed
106
        , fieldExtraKeys   = []
107 108
        , fieldDefault     = Nothing
        , fieldConstr      = Nothing
109
        , fieldIsOptional  = NotOptional
110 111 112 113 114 115 116 117 118 119 120 121 122
        }

-- | Sets the renamed constructor field.
renameField :: String -> Field -> Field
renameField constrName field = field { fieldConstr = Just constrName }

-- | Sets the default value on a field (makes it optional with a
-- default value).
defaultField :: Q Exp -> Field -> Field
defaultField defval field = field { fieldDefault = Just defval }

-- | Marks a field optional (turning its base type into a Maybe).
optionalField :: Field -> Field
123 124 125 126 127 128
optionalField field = field { fieldIsOptional = OptionalOmitNull }

-- | Marks a field optional (turning its base type into a Maybe), but
-- with 'Nothing' serialised explicitly as /null/.
optionalNullSerField :: Field -> Field
optionalNullSerField field = field { fieldIsOptional = OptionalSerializeNull }
129 130

-- | Sets custom functions on a field.
Iustin Pop's avatar
Iustin Pop committed
131 132 133 134 135 136 137 138
customField :: Name      -- ^ The name of the read function
            -> Name      -- ^ The name of the show function
            -> [String]  -- ^ The name of extra field keys
            -> Field     -- ^ The original field
            -> Field     -- ^ Updated field
customField readfn showfn extra field =
  field { fieldRead = Just (varE readfn), fieldShow = Just (varE showfn)
        , fieldExtraKeys = extra }
139

140 141 142
-- | Computes the record name for a given field, based on either the
-- string value in the JSON serialisation or the custom named if any
-- exists.
143 144
fieldRecordName :: Field -> String
fieldRecordName (Field { fieldName = name, fieldConstr = alias }) =
145
  fromMaybe (camelCase name) alias
146

147 148 149 150
-- | Computes the preferred variable name to use for the value of this
-- field. If the field has a specific constructor name, then we use a
-- first-letter-lowercased version of that; otherwise, we simply use
-- the field name. See also 'fieldRecordName'.
151
fieldVariable :: Field -> String
152 153 154
fieldVariable f =
  case (fieldConstr f) of
    Just name -> ensureLower name
Iustin Pop's avatar
Iustin Pop committed
155
    _ -> map (\c -> if c == '-' then '_' else c) $ fieldName f
156

157 158
-- | Compute the actual field type (taking into account possible
-- optional status).
159
actualFieldType :: Field -> Q Type
160
actualFieldType f | fieldIsOptional f /= NotOptional = [t| Maybe $t |]
161 162 163
                  | otherwise = t
                  where t = fieldType f

164 165
-- | Checks that a given field is not optional (for object types or
-- fields which should not allow this case).
166
checkNonOptDef :: (Monad m) => Field -> m ()
167 168 169 170 171
checkNonOptDef (Field { fieldIsOptional = OptionalOmitNull
                      , fieldName = name }) =
  fail $ "Optional field " ++ name ++ " used in parameter declaration"
checkNonOptDef (Field { fieldIsOptional = OptionalSerializeNull
                      , fieldName = name }) =
172 173 174 175 176
  fail $ "Optional field " ++ name ++ " used in parameter declaration"
checkNonOptDef (Field { fieldDefault = (Just _), fieldName = name }) =
  fail $ "Default field " ++ name ++ " used in parameter declaration"
checkNonOptDef _ = return ()

177 178 179 180 181 182 183 184 185 186
-- | Produces the expression that will de-serialise a given
-- field. Since some custom parsing functions might need to use the
-- entire object, we do take and pass the object to any custom read
-- functions.
loadFn :: Field   -- ^ The field definition
       -> Q Exp   -- ^ The value of the field as existing in the JSON message
       -> Q Exp   -- ^ The entire object in JSON object format
       -> Q Exp   -- ^ Resulting expression
loadFn (Field { fieldRead = Just readfn }) expr o = [| $expr >>= $readfn $o |]
loadFn _ expr _ = expr
187 188 189

-- * Common field declarations

190
-- | Timestamp fields description.
191 192 193 194 195 196
timeStampFields :: [Field]
timeStampFields =
    [ defaultField [| 0::Double |] $ simpleField "ctime" [t| Double |]
    , defaultField [| 0::Double |] $ simpleField "mtime" [t| Double |]
    ]

197
-- | Serial number fields description.
198 199 200 201
serialFields :: [Field]
serialFields =
    [ renameField  "Serial" $ simpleField "serial_no" [t| Int |] ]

202
-- | UUID fields description.
203 204 205
uuidFields :: [Field]
uuidFields = [ simpleField "uuid" [t| String |] ]

206 207 208
-- | Tag set type alias.
type TagSet = Set.Set String

Iustin Pop's avatar
Iustin Pop committed
209 210 211
-- | Tag field description.
tagsFields :: [Field]
tagsFields = [ defaultField [| Set.empty |] $
212
               simpleField "tags" [t| TagSet |] ]
Iustin Pop's avatar
Iustin Pop committed
213

Iustin Pop's avatar
Iustin Pop committed
214 215 216 217 218 219 220 221 222 223 224
-- * Internal types

-- | A simple field, in constrast to the customisable 'Field' type.
type SimpleField = (String, Q Type)

-- | A definition for a single constructor for a simple object.
type SimpleConstructor = (String, [SimpleField])

-- | A definition for ADTs with simple fields.
type SimpleObject = [SimpleConstructor]

225 226 227
-- | A type alias for a constructor of a regular object.
type Constructor = (String, [Field])

Iustin Pop's avatar
Iustin Pop committed
228 229
-- * Helper functions

230 231 232
-- | Ensure first letter is lowercase.
--
-- Used to convert type name to function prefix, e.g. in @data Aa ->
233
-- aaToRaw@.
234 235 236 237
ensureLower :: String -> String
ensureLower [] = []
ensureLower (x:xs) = toLower x:xs

238 239 240 241 242 243 244
-- | Ensure first letter is uppercase.
--
-- Used to convert constructor name to component
ensureUpper :: String -> String
ensureUpper [] = []
ensureUpper (x:xs) = toUpper x:xs

Iustin Pop's avatar
Iustin Pop committed
245 246 247 248 249 250
-- | Helper for quoted expressions.
varNameE :: String -> Q Exp
varNameE = varE . mkName

-- | showJSON as an expression, for reuse.
showJSONE :: Q Exp
251 252 253 254 255 256 257 258 259
showJSONE = varE 'JSON.showJSON

-- | makeObj as an expression, for reuse.
makeObjE :: Q Exp
makeObjE = varE 'JSON.makeObj

-- | fromObj (Ganeti specific) as an expression, for reuse.
fromObjE :: Q Exp
fromObjE = varE 'fromObj
Iustin Pop's avatar
Iustin Pop committed
260

261 262 263
-- | ToRaw function name.
toRawName :: String -> Name
toRawName = mkName . (++ "ToRaw") . ensureLower
264

265 266 267
-- | FromRaw function name.
fromRawName :: String -> Name
fromRawName = mkName . (++ "FromRaw") . ensureLower
268

269
-- | Converts a name to it's varE\/litE representations.
270
reprE :: Either String Name -> Q Exp
Iustin Pop's avatar
Iustin Pop committed
271 272
reprE = either stringE varE

273 274 275 276 277 278 279 280
-- | Smarter function application.
--
-- This does simply f x, except that if is 'id', it will skip it, in
-- order to generate more readable code when using -ddump-splices.
appFn :: Exp -> Exp -> Exp
appFn f x | f == VarE 'id = x
          | otherwise = AppE f x

281 282 283 284 285 286 287 288 289 290 291 292
-- | Builds a field for a normal constructor.
buildConsField :: Q Type -> StrictTypeQ
buildConsField ftype = do
  ftype' <- ftype
  return (NotStrict, ftype')

-- | Builds a constructor based on a simple definition (not field-based).
buildSimpleCons :: Name -> SimpleObject -> Q Dec
buildSimpleCons tname cons = do
  decl_d <- mapM (\(cname, fields) -> do
                    fields' <- mapM (buildConsField . snd) fields
                    return $ NormalC (mkName cname) fields') cons
293
  return $ DataD [] tname [] decl_d [''Show, ''Eq]
294 295 296 297 298 299 300 301 302 303 304 305 306

-- | Generate the save function for a given type.
genSaveSimpleObj :: Name                            -- ^ Object type
                 -> String                          -- ^ Function name
                 -> SimpleObject                    -- ^ Object definition
                 -> (SimpleConstructor -> Q Clause) -- ^ Constructor save fn
                 -> Q (Dec, Dec)
genSaveSimpleObj tname sname opdefs fn = do
  let sigt = AppT (AppT ArrowT (ConT tname)) (ConT ''JSON.JSValue)
      fname = mkName sname
  cclauses <- mapM fn opdefs
  return $ (SigD fname sigt, FunD fname cclauses)

307
-- * Template code for simple raw type-equivalent ADTs
308

309 310 311 312 313
-- | Generates a data type declaration.
--
-- The type will have a fixed list of instances.
strADTDecl :: Name -> [String] -> Dec
strADTDecl name constructors =
314 315
  DataD [] name []
          (map (flip NormalC [] . mkName) constructors)
316
          [''Show, ''Eq, ''Enum, ''Bounded, ''Ord]
317

318
-- | Generates a toRaw function.
319 320 321 322
--
-- This generates a simple function of the form:
--
-- @
323 324 325
-- nameToRaw :: Name -> /traw/
-- nameToRaw Cons1 = var1
-- nameToRaw Cons2 = \"value2\"
326
-- @
327 328
genToRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec]
genToRaw traw fname tname constructors = do
329
  let sigt = AppT (AppT ArrowT (ConT tname)) (ConT traw)
330
  -- the body clauses, matching on the constructor and returning the
331
  -- raw value
332
  clauses <- mapM  (\(c, v) -> clause [recP (mkName c) []]
333
                             (normalB (reprE v)) []) constructors
334 335
  return [SigD fname sigt, FunD fname clauses]

336
-- | Generates a fromRaw function.
337 338
--
-- The function generated is monadic and can fail parsing the
339
-- raw value. It is of the form:
340 341
--
-- @
342 343 344 345
-- nameFromRaw :: (Monad m) => /traw/ -> m Name
-- nameFromRaw s | s == var1       = Cons1
--               | s == \"value2\" = Cons2
--               | otherwise = fail /.../
346
-- @
347 348
genFromRaw :: Name -> Name -> Name -> [(String, Name)] -> Q [Dec]
genFromRaw traw fname tname constructors = do
349
  -- signature of form (Monad m) => String -> m $name
350
  sigt <- [t| (Monad m) => $(conT traw) -> m $(conT tname) |]
351 352 353 354 355 356 357 358 359 360 361 362 363
  -- clauses for a guarded pattern
  let varp = mkName "s"
      varpe = varE varp
  clauses <- mapM (\(c, v) -> do
                     -- the clause match condition
                     g <- normalG [| $varpe == $(varE v) |]
                     -- the clause result
                     r <- [| return $(conE (mkName c)) |]
                     return (g, r)) constructors
  -- the otherwise clause (fallback)
  oth_clause <- do
    g <- normalG [| otherwise |]
    r <- [|fail ("Invalid string value for type " ++
364
                 $(litE (stringL (nameBase tname))) ++ ": " ++ show $varpe) |]
365 366 367 368 369
    return (g, r)
  let fun = FunD fname [Clause [VarP varp]
                        (GuardedB (clauses++[oth_clause])) []]
  return [SigD fname sigt, fun]

370
-- | Generates a data type from a given raw format.
371 372 373 374 375 376 377 378 379
--
-- The format is expected to multiline. The first line contains the
-- type name, and the rest of the lines must contain two words: the
-- constructor name and then the string representation of the
-- respective constructor.
--
-- The function will generate the data type declaration, and then two
-- functions:
--
380
-- * /name/ToRaw, which converts the type to a raw type
381
--
382
-- * /name/FromRaw, which (monadically) converts from a raw type to the type
383
--
384
-- Note that this is basically just a custom show\/read instance,
385
-- nothing else.
386 387
declareADT :: Name -> String -> [(String, Name)] -> Q [Dec]
declareADT traw sname cons = do
388 389
  let name = mkName sname
      ddecl = strADTDecl name (map fst cons)
390
      -- process cons in the format expected by genToRaw
391
      cons' = map (\(a, b) -> (a, Right b)) cons
392 393 394
  toraw <- genToRaw traw (toRawName sname) name cons'
  fromraw <- genFromRaw traw (fromRawName sname) name cons
  return $ ddecl:toraw ++ fromraw
395

396 397 398 399 400
declareIADT :: String -> [(String, Name)] -> Q [Dec]
declareIADT = declareADT ''Int

declareSADT :: String -> [(String, Name)] -> Q [Dec]
declareSADT = declareADT ''String
401 402 403 404 405 406

-- | Creates the showJSON member of a JSON instance declaration.
--
-- This will create what is the equivalent of:
--
-- @
407
-- showJSON = showJSON . /name/ToRaw
408 409 410
-- @
--
-- in an instance JSON /name/ declaration
411 412 413
genShowJSON :: String -> Q Dec
genShowJSON name = do
  body <- [| JSON.showJSON . $(varE (toRawName name)) |]
414
  return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []]
415 416 417 418 419 420 421

-- | Creates the readJSON member of a JSON instance declaration.
--
-- This will create what is the equivalent of:
--
-- @
-- readJSON s = case readJSON s of
422
--                Ok s' -> /name/FromRaw s'
423 424 425 426 427 428 429 430
--                Error e -> Error /description/
-- @
--
-- in an instance JSON /name/ declaration
genReadJSON :: String -> Q Dec
genReadJSON name = do
  let s = mkName "s"
  body <- [| case JSON.readJSON $(varE s) of
431
               JSON.Ok s' -> $(varE (fromRawName name)) s'
432
               JSON.Error e ->
433
                   JSON.Error $ "Can't parse raw value for type " ++
434 435
                           $(stringE name) ++ ": " ++ e ++ " from " ++
                           show $(varE s)
436
           |]
437
  return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]
438 439 440

-- | Generates a JSON instance for a given type.
--
441
-- This assumes that the /name/ToRaw and /name/FromRaw functions
442 443 444 445 446 447
-- have been defined as by the 'declareSADT' function.
makeJSONInstance :: Name -> Q [Dec]
makeJSONInstance name = do
  let base = nameBase name
  showJ <- genShowJSON base
  readJ <- genReadJSON base
448
  return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) [readJ,showJ]]
449

Iustin Pop's avatar
Iustin Pop committed
450 451
-- * Template code for opcodes

452 453 454 455 456
-- | Transforms a CamelCase string into an_underscore_based_one.
deCamelCase :: String -> String
deCamelCase =
    intercalate "_" . map (map toUpper) . groupBy (\_ b -> not $ isUpper b)

457 458 459
-- | Transform an underscore_name into a CamelCase one.
camelCase :: String -> String
camelCase = concatMap (ensureUpper . drop 1) .
Iustin Pop's avatar
Iustin Pop committed
460
            groupBy (\_ b -> b /= '_' && b /= '-') . ('_':)
461

462
-- | Computes the name of a given constructor.
463 464 465 466 467
constructorName :: Con -> Q Name
constructorName (NormalC name _) = return name
constructorName (RecC name _)    = return name
constructorName x                = fail $ "Unhandled constructor " ++ show x

468 469 470 471 472 473 474 475 476
-- | Extract all constructor names from a given type.
reifyConsNames :: Name -> Q [String]
reifyConsNames name = do
  reify_result <- reify name
  case reify_result of
    TyConI (DataD _ _ _ cons _) -> mapM (liftM nameBase . constructorName) cons
    o -> fail $ "Unhandled name passed to reifyConsNames, expected\
                \ type constructor but got '" ++ show o ++ "'"

477
-- | Builds the generic constructor-to-string function.
478 479 480 481
--
-- This generates a simple function of the following form:
--
-- @
482 483
-- fname (ConStructorOne {}) = trans_fun("ConStructorOne")
-- fname (ConStructorTwo {}) = trans_fun("ConStructorTwo")
484 485
-- @
--
486 487
-- This builds a custom list of name\/string pairs and then uses
-- 'genToRaw' to actually generate the function.
488 489
genConstrToStr :: (String -> String) -> Name -> String -> Q [Dec]
genConstrToStr trans_fun name fname = do
490
  cnames <- reifyConsNames name
491
  let svalues = map (Left . trans_fun) cnames
492
  genToRaw ''String (mkName fname) name $ zip cnames svalues
493

494 495 496
-- | Constructor-to-string for OpCode.
genOpID :: Name -> String -> Q [Dec]
genOpID = genConstrToStr deCamelCase
497

498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519
-- | Builds a list with all defined constructor names for a type.
--
-- @
-- vstr :: String
-- vstr = [...]
-- @
--
-- Where the actual values of the string are the constructor names
-- mapped via @trans_fun@.
genAllConstr :: (String -> String) -> Name -> String -> Q [Dec]
genAllConstr trans_fun name vstr = do
  cnames <- reifyConsNames name
  let svalues = sort $ map trans_fun cnames
      vname = mkName vstr
      sig = SigD vname (AppT ListT (ConT ''String))
      body = NormalB (ListE (map (LitE . StringL) svalues))
  return $ [sig, ValD (VarP vname) body []]

-- | Generates a list of all defined opcode IDs.
genAllOpIDs :: Name -> String -> Q [Dec]
genAllOpIDs = genAllConstr deCamelCase

520
-- | OpCode parameter (field) type.
521 522 523 524 525 526 527 528
type OpParam = (String, Q Type, Q Exp)

-- | Generates the OpCode data type.
--
-- This takes an opcode logical definition, and builds both the
-- datatype and the JSON serialisation out of it. We can't use a
-- generic serialisation since we need to be compatible with Ganeti's
-- own, so we have a few quirks to work around.
529 530
genOpCode :: String        -- ^ Type name to use
          -> [Constructor] -- ^ Constructor name and parameters
531 532
          -> Q [Dec]
genOpCode name cons = do
533
  let tname = mkName name
534 535
  decl_d <- mapM (\(cname, fields) -> do
                    -- we only need the type of the field, without Q
536 537
                    fields' <- mapM (fieldTypeInfo "op") fields
                    return $ RecC (mkName cname) fields')
538
            cons
539
  let declD = DataD [] tname [] decl_d [''Show, ''Eq]
540

541
  let (allfsig, allffn) = genAllOpFields "allOpFields" cons
542 543
  save_decs <- genSaveOpCode tname "saveOpCode" "toDictOpCode"
               cons (uncurry saveConstructor) True
544
  (loadsig, loadfn) <- genLoadOpCode cons
545
  return $ [declD, allfsig, allffn, loadsig, loadfn] ++ save_decs
546 547 548

-- | Generates the function pattern returning the list of fields for a
-- given constructor.
549
genOpConsFields :: Constructor -> Clause
550 551 552 553 554 555 556
genOpConsFields (cname, fields) =
  let op_id = deCamelCase cname
      fvals = map (LitE . StringL) . sort . nub $
              concatMap (\f -> fieldName f:fieldExtraKeys f) fields
  in Clause [LitP (StringL op_id)] (NormalB $ ListE fvals) []

-- | Generates a list of all fields of an opcode constructor.
557 558
genAllOpFields  :: String        -- ^ Function name
                -> [Constructor] -- ^ Object definition
559 560 561 562 563 564 565
                -> (Dec, Dec)
genAllOpFields sname opdefs =
  let cclauses = map genOpConsFields opdefs
      other = Clause [WildP] (NormalB (ListE [])) []
      fname = mkName sname
      sigt = AppT  (AppT ArrowT (ConT ''String)) (AppT ListT (ConT ''String))
  in (SigD fname sigt, FunD fname (cclauses++[other]))
566 567 568 569 570

-- | Generates the \"save\" clause for an entire opcode constructor.
--
-- This matches the opcode with variables named the same as the
-- constructor fields (just so that the spliced in code looks nicer),
571
-- and passes those name plus the parameter definition to 'saveObjectField'.
572
saveConstructor :: String    -- ^ The constructor name
573
                -> [Field]   -- ^ The parameter definitions for this
574 575 576 577
                             -- constructor
                -> Q Clause  -- ^ Resulting clause
saveConstructor sname fields = do
  let cname = mkName sname
Iustin Pop's avatar
Iustin Pop committed
578
  fnames <- mapM (newName . fieldVariable) fields
579
  let pat = conP cname (map varP fnames)
580
  let felems = map (uncurry saveObjectField) (zip fnames fields)
581
      -- now build the OP_ID serialisation
Iustin Pop's avatar
Iustin Pop committed
582
      opid = [| [( $(stringE "OP_ID"),
583
                   JSON.showJSON $(stringE . deCamelCase $ sname) )] |]
584 585
      flist = listE (opid:felems)
      -- and finally convert all this to a json object
586
      flist' = [| concat $flist |]
587 588 589 590 591 592
  clause [pat] (normalB flist') []

-- | Generates the main save opcode function.
--
-- This builds a per-constructor match clause that contains the
-- respective constructor-serialisation code.
593
genSaveOpCode :: Name                      -- ^ Object ype
594 595
              -> String                    -- ^ To 'JSValue' function name
              -> String                    -- ^ To 'JSObject' function name
596 597
              -> [Constructor]             -- ^ Object definition
              -> (Constructor -> Q Clause) -- ^ Constructor save fn
598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615
              -> Bool                      -- ^ Whether to generate
                                           -- obj or just a
                                           -- list\/tuple of values
              -> Q [Dec]
genSaveOpCode tname jvalstr tdstr opdefs fn gen_object = do
  tdclauses <- mapM fn opdefs
  let typecon = ConT tname
      jvalname = mkName jvalstr
      jvalsig = AppT  (AppT ArrowT typecon) (ConT ''JSON.JSValue)
      tdname = mkName tdstr
  tdsig <- [t| $(return typecon) -> [(String, JSON.JSValue)] |]
  jvalclause <- if gen_object
                  then [| $makeObjE . $(varE tdname) |]
                  else [| JSON.showJSON . map snd . $(varE tdname) |]
  return [ SigD tdname tdsig
         , FunD tdname tdclauses
         , SigD jvalname jvalsig
         , ValD (VarP jvalname) (NormalB jvalclause) []]
616

617
-- | Generates load code for a single constructor of the opcode data type.
618
loadConstructor :: String -> [Field] -> Q Exp
619 620
loadConstructor sname fields = do
  let name = mkName sname
621
  fbinds <- mapM loadObjectField fields
622 623 624 625 626
  let (fnames, fstmts) = unzip fbinds
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
      fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
  return $ DoE fstmts'

627
-- | Generates the loadOpCode function.
628
genLoadOpCode :: [Constructor] -> Q (Dec, Dec)
629 630 631 632 633 634 635
genLoadOpCode opdefs = do
  let fname = mkName "loadOpCode"
      arg1 = mkName "v"
      objname = mkName "o"
      opid = mkName "op_id"
  st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
                                 (JSON.readJSON $(varE arg1)) |]
636
  st2 <- bindS (varP opid) [| $fromObjE $(varE objname) $(stringE "OP_ID") |]
637 638 639 640 641 642 643 644 645 646 647 648 649
  -- the match results (per-constructor blocks)
  mexps <- mapM (uncurry loadConstructor) opdefs
  fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |]
  let mpats = map (\(me, c) ->
                       let mp = LitP . StringL . deCamelCase . fst $ c
                       in Match mp (NormalB me) []
                  ) $ zip mexps opdefs
      defmatch = Match WildP (NormalB fails) []
      cst = NoBindS $ CaseE (VarE opid) $ mpats++[defmatch]
      body = DoE [st1, st2, cst]
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT (mkName "OpCode")) |]
  return $ (SigD fname sigt, FunD fname [Clause [VarP arg1] (NormalB body) []])

650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666
-- * Template code for luxi

-- | Constructor-to-string for LuxiOp.
genStrOfOp :: Name -> String -> Q [Dec]
genStrOfOp = genConstrToStr id

-- | Constructor-to-string for MsgKeys.
genStrOfKey :: Name -> String -> Q [Dec]
genStrOfKey = genConstrToStr ensureLower

-- | Generates the LuxiOp data type.
--
-- This takes a Luxi operation definition and builds both the
-- datatype and the function trnasforming the arguments to JSON.
-- We can't use anything less generic, because the way different
-- operations are serialized differs on both parameter- and top-level.
--
667
-- There are two things to be defined for each parameter:
668 669 670 671 672
--
-- * name
--
-- * type
--
673
genLuxiOp :: String -> [Constructor] -> Q [Dec]
674
genLuxiOp name cons = do
675
  let tname = mkName name
676 677 678 679 680 681
  decl_d <- mapM (\(cname, fields) -> do
                    -- we only need the type of the field, without Q
                    fields' <- mapM actualFieldType fields
                    let fields'' = zip (repeat NotStrict) fields'
                    return $ NormalC (mkName cname) fields'')
            cons
682
  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Eq]
683 684
  save_decs <- genSaveOpCode tname "opToArgs" "opToDict"
               cons saveLuxiConstructor False
Iustin Pop's avatar
Iustin Pop committed
685 686 687
  req_defs <- declareSADT "LuxiReq" .
              map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $
                  cons
688
  return $ declD:save_decs ++ req_defs
689 690

-- | Generates the \"save\" clause for entire LuxiOp constructor.
691
saveLuxiConstructor :: Constructor -> Q Clause
692
saveLuxiConstructor (sname, fields) = do
693
  let cname = mkName sname
694 695 696
  fnames <- mapM (newName . fieldVariable) fields
  let pat = conP cname (map varP fnames)
  let felems = map (uncurry saveObjectField) (zip fnames fields)
697
      flist = [| concat $(listE felems) |]
698
  clause [pat] (normalB flist) []
699

700 701 702 703 704 705 706 707 708 709 710 711 712 713 714
-- * "Objects" functionality

-- | Extract the field's declaration from a Field structure.
fieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
fieldTypeInfo field_pfx fd = do
  t <- actualFieldType fd
  let n = mkName . (field_pfx ++) . fieldRecordName $ fd
  return (n, NotStrict, t)

-- | Build an object declaration.
buildObject :: String -> String -> [Field] -> Q [Dec]
buildObject sname field_pfx fields = do
  let name = mkName sname
  fields_d <- mapM (fieldTypeInfo field_pfx) fields
  let decl_d = RecC name fields_d
715
  let declD = DataD [] name [] [decl_d] [''Show, ''Eq]
716 717 718
  ser_decls <- buildObjectSerialisation sname fields
  return $ declD:ser_decls

719
-- | Generates an object definition: data type and its JSON instance.
720 721 722 723 724 725 726 727
buildObjectSerialisation :: String -> [Field] -> Q [Dec]
buildObjectSerialisation sname fields = do
  let name = mkName sname
  savedecls <- genSaveObject saveObjectField sname fields
  (loadsig, loadfn) <- genLoadObject loadObjectField sname fields
  shjson <- objectShowJSON sname
  rdjson <- objectReadJSON sname
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
728
                 [rdjson, shjson]
729 730
  return $ savedecls ++ [loadsig, loadfn, instdecl]

731 732 733 734
-- | The toDict function name for a given type.
toDictName :: String -> Name
toDictName sname = mkName ("toDict" ++ sname)

735
-- | Generates the save object functionality.
736 737 738 739
genSaveObject :: (Name -> Field -> Q Exp)
              -> String -> [Field] -> Q [Dec]
genSaveObject save_fn sname fields = do
  let name = mkName sname
Iustin Pop's avatar
Iustin Pop committed
740
  fnames <- mapM (newName . fieldVariable) fields
741
  let pat = conP name (map varP fnames)
742
  let tdname = toDictName sname
743 744 745 746 747 748 749 750
  tdsigt <- [t| $(conT name) -> [(String, JSON.JSValue)] |]

  let felems = map (uncurry save_fn) (zip fnames fields)
      flist = listE felems
      -- and finally convert all this to a json object
      tdlist = [| concat $flist |]
      iname = mkName "i"
  tclause <- clause [pat] (normalB tdlist) []
751
  cclause <- [| $makeObjE . $(varE tdname) |]
752 753 754 755 756
  let fname = mkName ("save" ++ sname)
  sigt <- [t| $(conT name) -> JSON.JSValue |]
  return [SigD tdname tdsigt, FunD tdname [tclause],
          SigD fname sigt, ValD (VarP fname) (NormalB cclause) []]

757 758
-- | Generates the code for saving an object's field, handling the
-- various types of fields that we have.
759
saveObjectField :: Name -> Field -> Q Exp
760 761 762 763 764 765 766 767 768 769 770 771
saveObjectField fvar field =
  case fieldIsOptional field of
    OptionalOmitNull -> [| case $(varE fvar) of
                             Nothing -> []
                             Just v  -> [( $nameE, JSON.showJSON v )]
                         |]
    OptionalSerializeNull -> [| case $(varE fvar) of
                                  Nothing -> [( $nameE, JSON.JSNull )]
                                  Just v  -> [( $nameE, JSON.showJSON v )]
                              |]
    NotOptional ->
      case fieldShow field of
772 773 774
        -- Note: the order of actual:extra is important, since for
        -- some serialisation types (e.g. Luxi), we use tuples
        -- (positional info) rather than object (name info)
775 776
        Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |]
        Just fn -> [| let (actual, extra) = $fn $fvarE
777
                      in ($nameE, JSON.showJSON actual):extra
778 779
                    |]
  where nameE = stringE (fieldName field)
780 781
        fvarE = varE fvar

782
-- | Generates the showJSON clause for a given object name.
783 784 785
objectShowJSON :: String -> Q Dec
objectShowJSON name = do
  body <- [| JSON.showJSON . $(varE . mkName $ "save" ++ name) |]
786
  return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []]
787

788
-- | Generates the load object functionality.
789 790 791 792 793
genLoadObject :: (Field -> Q (Name, Stmt))
              -> String -> [Field] -> Q (Dec, Dec)
genLoadObject load_fn sname fields = do
  let name = mkName sname
      funname = mkName $ "load" ++ sname
794
      arg1 = mkName $ if null fields then "_" else "v"
795 796 797 798 799 800 801
      objname = mkName "o"
      opid = mkName "op_id"
  st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
                                 (JSON.readJSON $(varE arg1)) |]
  fbinds <- mapM load_fn fields
  let (fnames, fstmts) = unzip fbinds
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
802 803 804 805 806 807
      retstmt = [NoBindS (AppE (VarE 'return) cval)]
      -- FIXME: should we require an empty dict for an empty type?
      -- this allows any JSValue right now
      fstmts' = if null fields
                  then retstmt
                  else st1:fstmts ++ retstmt
808 809 810 811
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT name) |]
  return $ (SigD funname sigt,
            FunD funname [Clause [VarP arg1] (NormalB (DoE fstmts')) []])

812
-- | Generates code for loading an object's field.
813 814 815
loadObjectField :: Field -> Q (Name, Stmt)
loadObjectField field = do
  let name = fieldVariable field
Iustin Pop's avatar
Iustin Pop committed
816
  fvar <- newName name
817 818 819 820
  -- these are used in all patterns below
  let objvar = varNameE "o"
      objfield = stringE (fieldName field)
      loadexp =
821 822 823 824
        if fieldIsOptional field /= NotOptional
          -- we treat both optional types the same, since
          -- 'maybeFromObj' can deal with both missing and null values
          -- appropriately (the same)
825
          then [| $(varE 'maybeFromObj) $objvar $objfield |]
826 827
          else case fieldDefault field of
                 Just defv ->
828
                   [| $(varE 'fromObjWithDefault) $objvar
829
                      $objfield $defv |]
830
                 Nothing -> [| $fromObjE $objvar $objfield |]
831
  bexp <- loadFn field loadexp objvar
832 833 834

  return (fvar, BindS (VarP fvar) bexp)

835
-- | Builds the readJSON instance for a given object name.
836 837 838 839 840 841 842 843 844
objectReadJSON :: String -> Q Dec
objectReadJSON name = do
  let s = mkName "s"
  body <- [| case JSON.readJSON $(varE s) of
               JSON.Ok s' -> $(varE .mkName $ "load" ++ name) s'
               JSON.Error e ->
                 JSON.Error $ "Can't parse value for type " ++
                       $(stringE name) ++ ": " ++ e
           |]
845
  return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]
846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877

-- * Inheritable parameter tables implementation

-- | Compute parameter type names.
paramTypeNames :: String -> (String, String)
paramTypeNames root = ("Filled"  ++ root ++ "Params",
                       "Partial" ++ root ++ "Params")

-- | Compute information about the type of a parameter field.
paramFieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
paramFieldTypeInfo field_pfx fd = do
  t <- actualFieldType fd
  let n = mkName . (++ "P") . (field_pfx ++) .
          fieldRecordName $ fd
  return (n, NotStrict, AppT (ConT ''Maybe) t)

-- | Build a parameter declaration.
--
-- This function builds two different data structures: a /filled/ one,
-- in which all fields are required, and a /partial/ one, in which all
-- fields are optional. Due to the current record syntax issues, the
-- fields need to be named differrently for the two structures, so the
-- partial ones get a /P/ suffix.
buildParam :: String -> String -> [Field] -> Q [Dec]
buildParam sname field_pfx fields = do
  let (sname_f, sname_p) = paramTypeNames sname
      name_f = mkName sname_f
      name_p = mkName sname_p
  fields_f <- mapM (fieldTypeInfo field_pfx) fields
  fields_p <- mapM (paramFieldTypeInfo field_pfx) fields
  let decl_f = RecC name_f fields_f
      decl_p = RecC name_p fields_p
878 879
  let declF = DataD [] name_f [] [decl_f] [''Show, ''Eq]
      declP = DataD [] name_p [] [decl_p] [''Show, ''Eq]
880 881 882
  ser_decls_f <- buildObjectSerialisation sname_f fields
  ser_decls_p <- buildPParamSerialisation sname_p fields
  fill_decls <- fillParam sname field_pfx fields
883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899
  return $ [declF, declP] ++ ser_decls_f ++ ser_decls_p ++ fill_decls ++
           buildParamAllFields sname fields ++
           buildDictObjectInst name_f sname_f

-- | Builds a list of all fields of a parameter.
buildParamAllFields :: String -> [Field] -> [Dec]
buildParamAllFields sname fields =
  let vname = mkName ("all" ++ sname ++ "ParamFields")
      sig = SigD vname (AppT ListT (ConT ''String))
      val = ListE $ map (LitE . StringL . fieldName) fields
  in [sig, ValD (VarP vname) (NormalB val) []]

-- | Builds the 'DictObject' instance for a filled parameter.
buildDictObjectInst :: Name -> String -> [Dec]
buildDictObjectInst name sname =
  [InstanceD [] (AppT (ConT ''DictObject) (ConT name))
   [ValD (VarP 'toDict) (NormalB (VarE (toDictName sname))) []]]
900

901
-- | Generates the serialisation for a partial parameter.
902 903 904 905 906 907 908 909
buildPParamSerialisation :: String -> [Field] -> Q [Dec]
buildPParamSerialisation sname fields = do
  let name = mkName sname
  savedecls <- genSaveObject savePParamField sname fields
  (loadsig, loadfn) <- genLoadObject loadPParamField sname fields
  shjson <- objectShowJSON sname
  rdjson <- objectReadJSON sname
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
910
                 [rdjson, shjson]
911 912
  return $ savedecls ++ [loadsig, loadfn, instdecl]

913
-- | Generates code to save an optional parameter field.
914 915 916 917 918 919 920 921 922 923 924 925
savePParamField :: Name -> Field -> Q Exp
savePParamField fvar field = do
  checkNonOptDef field
  let actualVal = mkName "v"
  normalexpr <- saveObjectField actualVal field
  -- we have to construct the block here manually, because we can't
  -- splice-in-splice
  return $ CaseE (VarE fvar) [ Match (ConP 'Nothing [])
                                       (NormalB (ConE '[])) []
                             , Match (ConP 'Just [VarP actualVal])
                                       (NormalB normalexpr) []
                             ]
926 927

-- | Generates code to load an optional parameter field.
928 929 930 931
loadPParamField :: Field -> Q (Name, Stmt)
loadPParamField field = do
  checkNonOptDef field
  let name = fieldName field
Iustin Pop's avatar
Iustin Pop committed
932
  fvar <- newName name
933 934 935
  -- these are used in all patterns below
  let objvar = varNameE "o"
      objfield = stringE name
936
      loadexp = [| $(varE 'maybeFromObj) $objvar $objfield |]
937
  bexp <- loadFn field loadexp objvar
938 939 940 941 942 943
  return (fvar, BindS (VarP fvar) bexp)

-- | Builds a simple declaration of type @n_x = fromMaybe f_x p_x@.
buildFromMaybe :: String -> Q Dec
buildFromMaybe fname =
  valD (varP (mkName $ "n_" ++ fname))
944
         (normalB [| $(varE 'fromMaybe)
945 946 947
                        $(varNameE $ "f_" ++ fname)
                        $(varNameE $ "p_" ++ fname) |]) []

948 949
-- | Builds a function that executes the filling of partial parameter
-- from a full copy (similar to Python's fillDict).
950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971
fillParam :: String -> String -> [Field] -> Q [Dec]
fillParam sname field_pfx fields = do
  let fnames = map (\fd -> field_pfx ++ fieldRecordName fd) fields
      (sname_f, sname_p) = paramTypeNames sname
      oname_f = "fobj"
      oname_p = "pobj"
      name_f = mkName sname_f
      name_p = mkName sname_p
      fun_name = mkName $ "fill" ++ sname ++ "Params"
      le_full = ValD (ConP name_f (map (VarP . mkName . ("f_" ++)) fnames))
                (NormalB . VarE . mkName $ oname_f) []
      le_part = ValD (ConP name_p (map (VarP . mkName . ("p_" ++)) fnames))
                (NormalB . VarE . mkName $ oname_p) []
      obj_new = foldl (\accu vname -> AppE accu (VarE vname)) (ConE name_f)
                $ map (mkName . ("n_" ++)) fnames
  le_new <- mapM buildFromMaybe fnames
  funt <- [t| $(conT name_f) -> $(conT name_p) -> $(conT name_f) |]
  let sig = SigD fun_name funt
      fclause = Clause [VarP (mkName oname_f), VarP (mkName oname_p)]
                (NormalB $ LetE (le_full:le_part:le_new) obj_new) []
      fun = FunD fun_name [fclause]
  return [sig, fun]
972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065