Synnefo » snf-ganeti

import qualified Text.JSON as JSON

import Text.JSON.Pretty (pp_value)

-- * Exported types

-- | Class of objects that can be converted to 'JSObject'

-- | showJSON as an expression, for reuse.

showJSONE :: Q Exp

-- | ToRaw function name.

toRawName :: String -> Name

genShowJSON :: String -> Q Dec

genShowJSON name = do

  body <- [| JSON.showJSON . $(varE (toRawName name)) |]

-- | Creates the readJSON member of a JSON instance declaration.

--

                           $(stringE name) ++ ": " ++ e ++ " from " ++

                           show $(varE s)

           |]

-- | Generates a JSON instance for a given type.

--

                   JSON.showJSON $(stringE . deCamelCase $ sname) )] |]

      flist = listE (opid:felems)

      -- and finally convert all this to a json object

  clause [pat] (normalB flist') []

-- | Generates the main save opcode function.

      opid = mkName "op_id"

  st1 <- bindS (varP objname) [| liftM JSON.fromJSObject

                                 (JSON.readJSON $(varE arg1)) |]

  -- the match results (per-constructor blocks)

  mexps <- mapM (uncurry loadConstructor) opdefs

  fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |]

      tdlist = [| concat $flist |]

      iname = mkName "i"

  tclause <- clause [pat] (normalB tdlist) []

  let fname = mkName ("save" ++ sname)

  sigt <- [t| $(conT name) -> JSON.JSValue |]

  return [SigD tdname tdsigt, FunD tdname [tclause],

objectShowJSON :: String -> Q Dec

objectShowJSON name = do

  body <- [| JSON.showJSON . $(varE . mkName $ "save" ++ name) |]

-- | Generates the load object functionality.

genLoadObject :: (Field -> Q (Name, Stmt))

          -- we treat both optional types the same, since

          -- 'maybeFromObj' can deal with both missing and null values

          -- appropriately (the same)

          else case fieldDefault field of

                 Just defv ->

                      $objfield $defv |]

  bexp <- loadFn field loadexp objvar

  return (fvar, BindS (VarP fvar) bexp)

                 JSON.Error $ "Can't parse value for type " ++

                       $(stringE name) ++ ": " ++ e

           |]

-- * Inheritable parameter tables implementation

  -- these are used in all patterns below

  let objvar = varNameE "o"

      objfield = stringE name

  bexp <- loadFn field loadexp objvar

  return (fvar, BindS (VarP fvar) bexp)

buildFromMaybe :: String -> Q Dec

buildFromMaybe fname =

  valD (varP (mkName $ "n_" ++ fname))

                        $(varNameE $ "f_" ++ fname)

                        $(varNameE $ "p_" ++ fname) |]) []