|
definition:
|
genEntryFuncs :: String -> Entity -> [CFuncDecl]
genEntryFuncs mName (Entity name attrs) =
case head attrs of
(Attribute "Key" _ PKey _ ) ->
[ stCmtFunc ("Gets all `" ++ name ++ "` entities.")
(mName, "queryAll" ++ name ++ "s") 0 Public
(applyTC (mConn, "DBAction")
[listType (baseType (mName, name))])
[simpleRule []
(applyF (mER, "getAllEntries") [constF endescr])]
, stCmtFunc
("Gets all `" ++ name ++ "` entities satisfying a given predicate.")
(mName, "queryCond" ++ name) 0 Public
((baseType (mName, name) ~> boolType) ~>
applyTC (mConn, "DBAction")
[listType (baseType (mName, name))])
[simpleRule []
(applyF (mER, "getCondEntries") [constF endescr])]
, stCmtFunc ("Gets a `" ++ name ++ "` entry by a given key.")
(mName, "get" ++ name) 0 Public
(baseType (mName, name ++ "ID") ~>
applyTC (mConn, "DBAction") [baseType (mName, name)])
[simpleRule []
(applyF (mER, "getEntryWithKey")
[ constF endescr
, constF (mName, lname ++ "ColumnKey")
, constF (mName, lname ++ "ID")])]
, let numargs = length attrs - 1
args = map ((++"_p") . firstLow . attributeName) (tail attrs)
adoms = map attributeDomain (tail attrs)
in stCmtFunc ("Inserts a new `" ++ name ++ "` entity.")
(mName, "new" ++ name ++ attrs2WithKeys) numargs Public
(foldr (~>)
(applyTC (mConn, "DBAction") [baseType (mName, name)])
(map (attr2NewCType mName name) (tail attrs)))
[simpleRule (map cpvar args)
(applyF (mER, "insertNewEntry")
[ constF endescr
, constF (mName, "set" ++ name ++ "Key")
, constF (mName, name ++ "ID")
, applyF (mName, name)
(applyF (mName, name ++ "ID") [cInt 0]
: map domVar2NewExp (zip adoms args))
])]
, stCmtFunc ("Deletes an existing `" ++ name ++ "` entry by its key.")
(mName, "delete" ++ name) 0 Public
(baseType (mName, name) ~>
applyTC (mConn, "DBAction") [unitType])
[simpleRule []
(applyF (mER, "deleteEntry")
[ constF endescr
, constF (mName, lname ++ "ColumnKey")
, applyF (pre ".")
[constF (mName, lname ++ "ID"),
constF (mName, lname ++ "Key")]])]
, stCmtFunc ("Updates an existing `" ++ name ++ "` entry by its key.")
(mName, "update" ++ name) 0 Public
(baseType (mName, name) ~>
applyTC (mConn, "DBAction") [unitType])
[simpleRule []
(applyF (mER, "updateEntry") [constF endescr ])]
]
_ ->
let numargs = length attrs
args = map (\i -> 'k' : show i) [1 .. numargs]
in [ stCmtFunc ("Inserts a new `" ++ name ++ "` relation.")
(mName, "new" ++ name) numargs Public
(foldr (~>)
(applyTC (mConn, "DBAction") [unitType])
(map (getAttributeType mName name) attrs))
[simpleRule (map cpvar args)
(applyF (mER, "insertEntry")
[ constF endescr
, applyF (mName, name) (map cvar args)
])]
, stCmtFunc ("Deletes an existing `" ++ name ++ "` relation.")
(mName, "delete" ++ name) numargs Public
(foldr (~>)
(applyTC (mConn, "DBAction") [unitType])
(map (getAttributeType mName name) attrs))
[simpleRule (map cpvar args)
(applyF (mER, "deleteEntryR")
(constF endescr : concatMap attr2args (zip attrs args)))]
, case attrs of
[Attribute aname1 (KeyDom adom1) _ _,
Attribute aname2 (KeyDom adom2) _ _] ->
stCmtFunc ("Gets the associated `" ++ adom1 ++
"` entities for a given `" ++ adom2 ++ "` entity\n" ++
"w.r.t. the `" ++ name ++ "` relation.")
(mName, "get" ++ name ++ adom1 ++ adom2 ++ "s") 1 Public
(baseType (mName,adom1) ~>
applyTC (mConn, "DBAction")
[listType (baseType (mName,adom2))])
[simpleRule [cpvar "en"]
(applyF (mER,">+=")
[ applyF (mER, "getEntriesWithColVal")
[ constF endescr
, constF (mName, lname ++ "Column" ++ aname1)
, applyF (mName, firstLow adom1 ++ "ID")
[applyF (mName, firstLow adom1 ++ "Key") [cvar "en"]]
]
, CLambda [cpvar "vals"]
(applyF (pre "mapM")
[ constF (mName, "get" ++ adom2)
, applyF (pre "map")
[ constF (mName, lname ++ aname2)
, cvar "vals"]])
])]
_ -> error $ "Non-binary relation entity " ++ name
]
where
lname = firstLow name
endescr = (mName, lname ++ "_CDBI_Description")
attr2args (Attribute aname adom _ _, arg) =
[ constF (mName, lname ++ "Column" ++ aname)
, case adom of
KeyDom en -> applyF (mName, firstLow en ++ "ID") [cvar arg]
_ -> error $ "No KeyDom attribute in relation entity " ++ name
]
attrs2WithKeys = concatMap (("With"++) . attributeName)
(filter isForeignKey attrs)
|