X-Git-Url: https://code.grnet.gr/git/ganeti-local/blobdiff_plain/ebf380646857819d447b10dd36f82edffc9bea00..79eef90baacbd6692aa761605b83ede7bfa9fa9f:/htools/Ganeti/THH.hs?ds=sidebyside diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs index b3c97f6..1dc5533 100644 --- a/htools/Ganeti/THH.hs +++ b/htools/Ganeti/THH.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} {-| TemplateHaskell helper for HTools. @@ -10,7 +10,7 @@ needs in this module (except the one for unittests). {- -Copyright (C) 2011 Google Inc. +Copyright (C) 2011, 2012 Google Inc. 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 @@ -34,19 +34,138 @@ module Ganeti.THH ( declareSADT , makeJSONInstance , genOpID , genOpCode - , noDefault , genStrOfOp , genStrOfKey , genLuxiOp + , Field + , simpleField + , defaultField + , optionalField + , renameField + , containerField + , customField + , timeStampFields + , uuidFields + , serialFields + , buildObject + , buildObjectSerialisation + , buildParam + , Container ) where +import Control.Arrow import Control.Monad (liftM, liftM2) import Data.Char import Data.List +import qualified Data.Map as M import Language.Haskell.TH import qualified Text.JSON as JSON +import Ganeti.HTools.JSON + +-- * Exported types + +type Container = M.Map String + +-- | Serialised field data type. +data Field = Field { fieldName :: String + , fieldType :: Q Type + , fieldRead :: Maybe (Q Exp) + , fieldShow :: Maybe (Q Exp) + , fieldDefault :: Maybe (Q Exp) + , fieldConstr :: Maybe String + , fieldIsContainer :: Bool + , fieldIsOptional :: Bool + } + +-- | Generates a simple field. +simpleField :: String -> Q Type -> Field +simpleField fname ftype = + Field { fieldName = fname + , fieldType = ftype + , fieldRead = Nothing + , fieldShow = Nothing + , fieldDefault = Nothing + , fieldConstr = Nothing + , fieldIsContainer = False + , fieldIsOptional = False + } + +-- | 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 +optionalField field = field { fieldIsOptional = True } + +-- | Marks a field as a container. +containerField :: Field -> Field +containerField field = field { fieldIsContainer = True } + +-- | Sets custom functions on a field. +customField :: Q Exp -> Q Exp -> Field -> Field +customField readfn showfn field = + field { fieldRead = Just readfn, fieldShow = Just showfn } + +fieldRecordName :: Field -> String +fieldRecordName (Field { fieldName = name, fieldConstr = alias }) = + maybe (camelCase name) id 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 +-- first-letter-lowercased version of that; otherwise, we simply use +-- the field name. See also 'fieldRecordName'. +fieldVariable :: Field -> String +fieldVariable f = + case (fieldConstr f) of + Just name -> ensureLower name + _ -> fieldName f + +actualFieldType :: Field -> Q Type +actualFieldType f | fieldIsContainer f = [t| Container $t |] + | fieldIsOptional f = [t| Maybe $t |] + | otherwise = t + where t = fieldType f + +checkNonOptDef :: (Monad m) => Field -> m () +checkNonOptDef (Field { fieldIsOptional = True, fieldName = name }) = + fail $ "Optional field " ++ name ++ " used in parameter declaration" +checkNonOptDef (Field { fieldDefault = (Just _), fieldName = name }) = + fail $ "Default field " ++ name ++ " used in parameter declaration" +checkNonOptDef _ = return () + +loadFn :: Field -> Q Exp -> Q Exp +loadFn (Field { fieldIsContainer = True }) expr = [| $expr >>= readContainer |] +loadFn (Field { fieldRead = Just readfn }) expr = [| $expr >>= $readfn |] +loadFn _ expr = expr + +saveFn :: Field -> Q Exp -> Q Exp +saveFn (Field { fieldIsContainer = True }) expr = [| showContainer $expr |] +saveFn (Field { fieldRead = Just readfn }) expr = [| $readfn $expr |] +saveFn _ expr = expr + +-- * 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 |] ] + -- * Helper functions -- | Ensure first letter is lowercase. @@ -57,6 +176,13 @@ ensureLower :: String -> String ensureLower [] = [] ensureLower (x:xs) = toLower x:xs +-- | Ensure first letter is uppercase. +-- +-- Used to convert constructor name to component +ensureUpper :: String -> String +ensureUpper [] = [] +ensureUpper (x:xs) = toUpper x:xs + -- | Helper for quoted expressions. varNameE :: String -> Q Exp varNameE = varE . mkName @@ -86,6 +212,18 @@ appFn :: Exp -> Exp -> Exp appFn f x | f == VarE 'id = x | otherwise = AppE f x +-- | Container loader +readContainer :: (Monad m, JSON.JSON a) => + JSON.JSObject JSON.JSValue -> m (Container a) +readContainer obj = do + let kjvlist = JSON.fromJSObject obj + kalist <- mapM (\(k, v) -> fromKeyValue k v >>= \a -> return (k, a)) kjvlist + return $ M.fromList kalist + +-- | Container dumper +showContainer :: (JSON.JSON a) => Container a -> JSON.JSValue +showContainer = JSON.makeObj . map (second JSON.showJSON) . M.toList + -- * Template code for simple raw type-equivalent ADTs -- | Generates a data type declaration. @@ -108,7 +246,7 @@ strADTDecl name constructors = -- @ genToRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec] genToRaw traw fname tname constructors = do - sigt <- [t| $(conT tname) -> $(conT traw) |] + let sigt = AppT (AppT ArrowT (ConT tname)) (ConT traw) -- the body clauses, matching on the constructor and returning the -- raw value clauses <- mapM (\(c, v) -> clause [recP (mkName c) []] @@ -190,8 +328,10 @@ declareSADT = declareADT ''String -- @ -- -- in an instance JSON /name/ declaration -genShowJSON :: String -> Q [Dec] -genShowJSON name = [d| showJSON = JSON.showJSON . $(varE (toRawName name)) |] +genShowJSON :: String -> Q Dec +genShowJSON name = do + body <- [| JSON.showJSON . $(varE (toRawName name)) |] + return $ FunD (mkName "showJSON") [Clause [] (NormalB body) []] -- | Creates the readJSON member of a JSON instance declaration. -- @@ -211,7 +351,8 @@ genReadJSON name = do JSON.Ok s' -> $(varE (fromRawName name)) s' JSON.Error e -> JSON.Error $ "Can't parse raw value for type " ++ - $(stringE name) ++ ": " ++ e + $(stringE name) ++ ": " ++ e ++ " from " ++ + show $(varE s) |] return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []] @@ -224,7 +365,7 @@ makeJSONInstance name = do let base = nameBase name showJ <- genShowJSON base readJ <- genReadJSON base - return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) (readJ:showJ)] + return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) [readJ,showJ]] -- * Template code for opcodes @@ -233,6 +374,11 @@ deCamelCase :: String -> String deCamelCase = intercalate "_" . map (map toUpper) . groupBy (\_ b -> not $ isUpper b) +-- | Transform an underscore_name into a CamelCase one. +camelCase :: String -> String +camelCase = concatMap (ensureUpper . drop 1) . + groupBy (\_ b -> b /= '_') . ('_':) + -- | Computes the name of a given constructor. constructorName :: Con -> Q Name constructorName (NormalC name _) = return name @@ -270,27 +416,15 @@ type OpParam = (String, Q Type, Q Exp) -- 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. --- --- There are three things to be defined for each parameter: --- --- * name --- --- * type; if this is 'Maybe', will only be serialised if it's a --- 'Just' value --- --- * default; if missing, won't raise an exception, but will instead --- use the default --- genOpCode :: String -- ^ Type name to use - -> [(String, [OpParam])] -- ^ Constructor name and parameters + -> [(String, [Field])] -- ^ Constructor name and parameters -> Q [Dec] genOpCode name cons = do decl_d <- mapM (\(cname, fields) -> do -- we only need the type of the field, without Q - fields' <- mapM (\(_, qt, _) -> - qt >>= \t -> return (NotStrict, t)) - fields - return $ NormalC (mkName cname) fields') + fields' <- mapM actualFieldType fields + let fields'' = zip (repeat NotStrict) fields' + return $ NormalC (mkName cname) fields'') cons let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq] @@ -305,42 +439,23 @@ isOptional :: Type -> Bool isOptional (AppT (ConT dt) _) | dt == ''Maybe = True isOptional _ = False --- | Generates the \"save\" expression for a single opcode parameter. --- --- There is only one special handling mode: if the parameter is of --- 'Maybe' type, then we only save it if it's a 'Just' value, --- otherwise we skip it. -saveField :: Name -- ^ The name of variable that contains the value - -> OpParam -- ^ Parameter definition - -> Q Exp -saveField fvar (fname, qt, _) = do - t <- qt - let fnexp = stringE fname - fvare = varE fvar - (if isOptional t - then [| case $fvare of - Just v' -> [( $fnexp, $showJSONE v')] - Nothing -> [] - |] - else [| [( $fnexp, $showJSONE $fvare )] |]) - -- | 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), --- and passes those name plus the parameter definition to 'saveField'. +-- and passes those name plus the parameter definition to 'saveObjectField'. saveConstructor :: String -- ^ The constructor name - -> [OpParam] -- ^ The parameter definitions for this + -> [Field] -- ^ The parameter definitions for this -- constructor -> Q Clause -- ^ Resulting clause saveConstructor sname fields = do let cname = mkName sname - let fnames = map (\(n, _, _) -> mkName n) fields + let fnames = map (mkName . fieldVariable) fields let pat = conP cname (map varP fnames) - let felems = map (uncurry saveField) (zip fnames fields) + let felems = map (uncurry saveObjectField) (zip fnames fields) -- now build the OP_ID serialisation opid = [| [( $(stringE "OP_ID"), - $showJSONE $(stringE . deCamelCase $ sname) )] |] + JSON.showJSON $(stringE . deCamelCase $ sname) )] |] flist = listE (opid:felems) -- and finally convert all this to a json object flist' = [| $(varNameE "makeObj") (concat $flist) |] @@ -350,51 +465,23 @@ saveConstructor sname fields = do -- -- This builds a per-constructor match clause that contains the -- respective constructor-serialisation code. -genSaveOpCode :: [(String, [OpParam])] -> Q (Dec, Dec) +genSaveOpCode :: [(String, [Field])] -> Q (Dec, Dec) genSaveOpCode opdefs = do cclauses <- mapM (uncurry saveConstructor) opdefs let fname = mkName "saveOpCode" sigt <- [t| $(conT (mkName "OpCode")) -> JSON.JSValue |] return $ (SigD fname sigt, FunD fname cclauses) --- | Generates the \"load\" field for a single parameter. --- --- There is custom handling, depending on how the parameter is --- specified. For a 'Maybe' type parameter, we allow that it is not --- present (via 'Utils.maybeFromObj'). Otherwise, if there is a --- default value, we allow the parameter to be abset, and finally if --- there is no default value, we require its presence. -loadField :: OpParam -> Q (Name, Stmt) -loadField (fname, qt, qdefa) = do - let fvar = mkName fname - t <- qt - defa <- qdefa - -- these are used in all patterns below - let objvar = varNameE "o" - objfield = stringE fname - bexp <- if isOptional t - then [| $((varNameE "maybeFromObj")) $objvar $objfield |] - else case defa of - AppE (ConE dt) defval | dt == 'Just -> - -- but has a default value - [| $(varNameE "fromObjWithDefault") - $objvar $objfield $(return defval) |] - ConE dt | dt == 'Nothing -> - [| $(varNameE "fromObj") $objvar $objfield |] - s -> fail $ "Invalid default value " ++ show s ++ - ", expecting either 'Nothing' or a 'Just defval'" - return (fvar, BindS (VarP fvar) bexp) - -loadConstructor :: String -> [OpParam] -> Q Exp +loadConstructor :: String -> [Field] -> Q Exp loadConstructor sname fields = do let name = mkName sname - fbinds <- mapM loadField fields + fbinds <- mapM loadObjectField fields 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' -genLoadOpCode :: [(String, [OpParam])] -> Q (Dec, Dec) +genLoadOpCode :: [(String, [Field])] -> Q (Dec, Dec) genLoadOpCode opdefs = do let fname = mkName "loadOpCode" arg1 = mkName "v" @@ -417,10 +504,6 @@ genLoadOpCode opdefs = do sigt <- [t| JSON.JSValue -> JSON.Result $(conT (mkName "OpCode")) |] return $ (SigD fname sigt, FunD fname [Clause [VarP arg1] (NormalB body) []]) --- | No default type. -noDefault :: Q Exp -noDefault = conE 'Nothing - -- * Template code for luxi -- | Constructor-to-string for LuxiOp. @@ -458,9 +541,12 @@ genLuxiOp name cons = do fields return $ NormalC (mkName cname) fields') cons - let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read] + let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq] (savesig, savefn) <- genSaveLuxiOp cons - return [declD, savesig, savefn] + req_defs <- declareSADT "LuxiReq" . + map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $ + cons + return $ [declD, savesig, savefn] ++ req_defs -- | Generates the \"save\" expression for a single luxi parameter. saveLuxiField :: Name -> LuxiParam -> Q Exp @@ -486,3 +572,226 @@ genSaveLuxiOp opdefs = do let fname = mkName "opToArgs" cclauses <- mapM saveLuxiConstructor opdefs return $ (SigD fname sigt, FunD fname cclauses) + +-- * "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 + let declD = DataD [] name [] [decl_d] [''Show, ''Read, ''Eq] + ser_decls <- buildObjectSerialisation sname fields + return $ declD:ser_decls + +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)) + [rdjson, shjson] + return $ savedecls ++ [loadsig, loadfn, instdecl] + +genSaveObject :: (Name -> Field -> Q Exp) + -> String -> [Field] -> Q [Dec] +genSaveObject save_fn sname fields = do + let name = mkName sname + let fnames = map (mkName . fieldVariable) fields + let pat = conP name (map varP fnames) + let tdname = mkName ("toDict" ++ sname) + 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) [] + cclause <- [| $(varNameE "makeObj") . $(varE tdname) |] + 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) []] + +saveObjectField :: Name -> Field -> Q Exp +saveObjectField fvar field + | isContainer = [| [( $nameE , JSON.showJSON . showContainer $ $fvarE)] |] + | fisOptional = [| case $(varE fvar) of + Nothing -> [] + Just v -> [( $nameE, JSON.showJSON v)] + |] + | otherwise = case fieldShow field of + Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |] + Just fn -> [| [( $nameE, JSON.showJSON . $fn $ $fvarE)] |] + where isContainer = fieldIsContainer field + fisOptional = fieldIsOptional field + 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 + let name = mkName sname + funname = mkName $ "load" ++ sname + arg1 = mkName "v" + 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 + fstmts' = st1:fstmts ++ [NoBindS (AppE (VarE 'return) cval)] + sigt <- [t| JSON.JSValue -> JSON.Result $(conT name) |] + return $ (SigD funname sigt, + FunD funname [Clause [VarP arg1] (NormalB (DoE fstmts')) []]) + +loadObjectField :: Field -> Q (Name, Stmt) +loadObjectField field = do + let name = fieldVariable field + fvar = mkName name + -- these are used in all patterns below + let objvar = varNameE "o" + objfield = stringE (fieldName field) + loadexp = + if fieldIsOptional field + then [| $(varNameE "maybeFromObj") $objvar $objfield |] + else case fieldDefault field of + Just defv -> + [| $(varNameE "fromObjWithDefault") $objvar + $objfield $defv |] + Nothing -> [| $(varNameE "fromObj") $objvar $objfield |] + bexp <- loadFn field loadexp + + return (fvar, BindS (VarP fvar) bexp) + +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 + |] + return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []] + +-- * 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 + let declF = DataD [] name_f [] [decl_f] [''Show, ''Read, ''Eq] + declP = DataD [] name_p [] [decl_p] [''Show, ''Read, ''Eq] + ser_decls_f <- buildObjectSerialisation sname_f fields + ser_decls_p <- buildPParamSerialisation sname_p fields + 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 + 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)) + [rdjson, shjson] + return $ savedecls ++ [loadsig, loadfn, instdecl] + +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) [] + ] +loadPParamField :: Field -> Q (Name, Stmt) +loadPParamField field = do + checkNonOptDef field + let name = fieldName field + fvar = mkName name + -- these are used in all patterns below + let objvar = varNameE "o" + objfield = stringE name + loadexp = [| $(varNameE "maybeFromObj") $objvar $objfield |] + bexp <- loadFn field loadexp + 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)) + (normalB [| $(varNameE "fromMaybe") + $(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 + (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]