Synnefo » snf-ganeti

import Control.Monad (liftM)

import Data.Char

import Data.List

import qualified Data.Set as Set

import Language.Haskell.TH

customField readfn showfn field =

  field { fieldRead = Just (varE readfn), fieldShow = Just (varE showfn) }

fieldRecordName :: Field -> String

fieldRecordName (Field { fieldName = name, fieldConstr = alias }) =

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

-- * Common field declarations

timeStampFields :: [Field]

timeStampFields =

    [ defaultField [| 0::Double |] $ simpleField "ctime" [t| Double |]

    , defaultField [| 0::Double |] $ simpleField "mtime" [t| Double |]

    ]

serialFields :: [Field]

serialFields =

    [ renameField  "Serial" $ simpleField "serial_no" [t| Int |] ]

uuidFields :: [Field]

uuidFields = [ simpleField "uuid" [t| String |] ]

fromRawName :: String -> Name

fromRawName = mkName . (++ "FromRaw") . ensureLower

reprE :: Either String Name -> Q Exp

reprE = either stringE varE

--

-- * /name/FromRaw, which (monadically) converts from a raw type to the type

--

-- nothing else.

declareADT :: Name -> String -> [(String, Name)] -> Q [Dec]

declareADT traw sname cons = do

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

-- @

--

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

genConstrToStr trans_fun name fname = do

  cnames <- reifyConsNames name

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

  return $ (SigD fname sigt, FunD fname cclauses)

loadConstructor :: String -> [Field] -> Q Exp

loadConstructor sname fields = do

  let name = mkName sname

      fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)]

  return $ DoE fstmts'

genLoadOpCode :: [(String, [Field])] -> Q (Dec, Dec)

genLoadOpCode opdefs = do

  let fname = mkName "loadOpCode"

  ser_decls <- buildObjectSerialisation sname fields

  return $ declD:ser_decls

buildObjectSerialisation :: String -> [Field] -> Q [Dec]

buildObjectSerialisation sname fields = do

  let name = mkName sname

                 [rdjson, shjson]

  return $ savedecls ++ [loadsig, loadfn, instdecl]

genSaveObject :: (Name -> Field -> Q Exp)

              -> String -> [Field] -> Q [Dec]

genSaveObject save_fn sname fields = do

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

          SigD fname sigt, ValD (VarP fname) (NormalB cclause) []]

saveObjectField :: Name -> Field -> Q Exp

saveObjectField fvar field

  | fisOptional = [| case $(varE fvar) of

        nameE = stringE (fieldName field)

        fvarE = varE fvar

objectShowJSON :: String -> Q Dec

objectShowJSON name = do

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

  return $ FunD (mkName "showJSON") [Clause [] (NormalB body) []]

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

              -> String -> [Field] -> Q (Dec, Dec)

genLoadObject load_fn sname fields = do

  return $ (SigD funname sigt,

            FunD funname [Clause [VarP arg1] (NormalB (DoE fstmts')) []])

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

loadObjectField field = do

  let name = fieldVariable field

  return (fvar, BindS (VarP fvar) bexp)

objectReadJSON :: String -> Q Dec

objectReadJSON name = do

  let s = mkName "s"

  fill_decls <- fillParam sname field_pfx fields

  return $ [declF, declP] ++ ser_decls_f ++ ser_decls_p ++ fill_decls

buildPParamSerialisation :: String -> [Field] -> Q [Dec]

buildPParamSerialisation sname fields = do

  let name = mkName sname

                 [rdjson, shjson]

  return $ savedecls ++ [loadsig, loadfn, instdecl]

savePParamField :: Name -> Field -> Q Exp

savePParamField fvar field = do

  checkNonOptDef field

                             , Match (ConP 'Just [VarP actualVal])

                                       (NormalB normalexpr) []

                             ]

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

loadPParamField field = do

  checkNonOptDef field

                        $(varNameE $ "f_" ++ fname)

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

fillParam :: String -> String -> [Field] -> Q [Dec]

fillParam sname field_pfx fields = do

  let fnames = map (\fd -> field_pfx ++ fieldRecordName fd) fields