Synnefo » snf-ganeti

                  , genStrOfOp

                  , genStrOfKey

                  , genLuxiOp

-- | Builds the generic constructor-to-string function.

-- fname (ConStructorOne {}) = trans_fun("ConStructorOne")

-- fname (ConStructorTwo {}) = trans_fun("ConStructorTwo")

genConstrToStr :: (String -> String) -> Name -> String -> Q [Dec]

genConstrToStr trans_fun name fname = do

  let svalues = map (Left . trans_fun) cnames

-- | Constructor-to-string for OpCode.

genOpID :: Name -> String -> Q [Dec]

genOpID = genConstrToStr deCamelCase

-- * 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

-- | LuxiOp parameter type.

type LuxiParam = (String, Q Type, Q Exp)

-- | 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.

--

-- There are three things to be defined for each parameter:

--

-- * name

--

-- * type

--

-- * operation; this is the operation performed on the parameter before

--   serialization

--

genLuxiOp :: String -> [(String, [LuxiParam], Q Exp)] -> Q [Dec]

genLuxiOp name cons = do

  decl_d <- mapM (\(cname, fields, _) -> do

                    fields' <- mapM (\(_, qt, _) ->

                                         qt >>= \t -> return (NotStrict, t))

                               fields

                    return $ NormalC (mkName cname) fields')

            cons

  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read]

  (savesig, savefn) <- genSaveLuxiOp cons

  return [declD, savesig, savefn]

-- | Generates the \"save\" clause for entire LuxiOp constructor.

saveLuxiConstructor :: (String, [LuxiParam], Q Exp) -> Q Clause

saveLuxiConstructor (sname, fields, finfn) =

  let cname = mkName sname

      fnames = map (\(nm, _, _) -> mkName nm) fields

      pat = conP cname (map varP fnames)

      flist = map (\(nm, _, fn) -> appE fn $ varNameE nm) fields

      finval = appE finfn (tupE flist)

  in

    clause [pat] (normalB finval) []

-- | Generates the main save LuxiOp function.

genSaveLuxiOp :: [(String, [LuxiParam], Q Exp)] -> Q (Dec, Dec)

genSaveLuxiOp opdefs = do

  sigt <- [t| $(conT (mkName "LuxiOp")) -> JSON.JSValue |]

  let fname = mkName "opToArgs"

  cclauses <- mapM saveLuxiConstructor opdefs

  return $ (SigD fname sigt, FunD fname cclauses)