|
sourcecode:
|
module Spicey.ViewGeneration where
import AbstractCurry.Types
import AbstractCurry.Build
import Database.ERD
import Database.ERD.Goodies
import Spicey.GenerationHelper
-- "main"-function
generateViewsForEntity :: String -> [Entity] -> Entity -> [Relationship]
-> CurryProg
generateViewsForEntity erdname allEntities
(Entity ename attrlist) relationships =
let noKeyAttrs = filter (\a -> notKey a && notPKey a) attrlist
noPKeyAttrs = filter notPKey attrlist
in simpleCurryProg
(viewModuleName ename)
[ listModule, timeModule
, "HTML.Base", bootstrapModule, "HTML.WUI"
, model erdname
, "Config.EntityRoutes"
, sessionInfoModule, spiceyModule
, entitiesToHtmlModule erdname] -- imports
[] -- typedecls
-- functions
[
wuiSpec erdname (Entity ename noKeyAttrs) relationships allEntities,
tuple2Entity erdname (Entity ename noPKeyAttrs) relationships allEntities,
entity2Tuple erdname (Entity ename noPKeyAttrs) relationships allEntities,
wuiType erdname (Entity ename noKeyAttrs) relationships allEntities,
showView erdname (Entity ename noKeyAttrs) relationships allEntities,
leqEntity erdname (Entity ename noKeyAttrs) relationships allEntities,
listView erdname (Entity ename noKeyAttrs) relationships allEntities
]
[] -- opdecls
type ViewGenerator = String -> Entity -> [Relationship] -> [Entity] -> CFuncDecl
wuiSpec :: ViewGenerator
wuiSpec erdname (Entity entityName attrlist) relationships allEntities =
let
manyToManyEntities = manyToMany allEntities (Entity entityName attrlist)
manyToOneEntities = manyToOne (Entity entityName attrlist) relationships
argumentCount = length attrlist + length manyToOneEntities
+ length manyToManyEntities
in
stCmtFunc
("The WUI specification for the entity type "++entityName++".\n"++
if null manyToOneEntities && null manyToManyEntities
then ""
else "It also includes fields for associated entities.")
(viewModuleName entityName, "w"++entityName) 2 Public
(foldr CFuncType
(applyTC (wuiModule "WuiSpec")
[entityInterface attrlist manyToOneEntities manyToManyEntities])
(map (\e -> listType (ctvar e)) -- possible values
(manyToOneEntities ++ map fst manyToManyEntities))
)
[simpleRule
(map (\ (en,er) -> CPVar (1, lowerFirst $ er ++ en ++ "List"))
(map (\n -> (n,"")) manyToOneEntities ++ manyToManyEntities))
(applyF (wuiModule "withRendering") [
(if (argumentCount == 1) then
head (attrWidgets attrlist)
else
applyF (combinator argumentCount)
( attrWidgets attrlist ++
map (\e -> applyF (wuiModule "wSelect")
[constF (entitiesToHtmlModule erdname,
lowerFirst e ++ "ToShortView"),
CVar (1, lowerFirst $ e ++ "List")])
manyToOneEntities ++
map (\ (ename,erel) ->
applyF (wuiModule "wMultiCheckSelect")
[CLambda [CPVar (1, lowerFirst ename)]
(list2ac [
applyF (html "htxt") [
applyF (entitiesToHtmlModule erdname,
lowerFirst ename ++ "ToShortView")
[CVar (1, lowerFirst ename)]
]]),
CVar (1, lowerFirst $ erel ++ ename ++ "List")
]) manyToManyEntities
)
),
applyF (spiceyModule, "renderLabels")
[constF (entitiesToHtmlModule erdname,
lowerFirst entityName ++ "LabelList")]
]
)]
tuple2Entity :: ViewGenerator
tuple2Entity erdname (Entity entityName attrlist) relationships allEntities =
let
manyToManyEntities = manyToMany allEntities (Entity entityName attrlist)
manyToOneEntities = manyToOne (Entity entityName attrlist) relationships
in
stCmtFunc
("Transformation from data of a WUI form to entity type "++entityName++".")
(viewModuleName entityName, "tuple2"++entityName) 2 Public
(
foldr CFuncType
(if null manyToManyEntities
then baseType (model erdname, entityName)
else tupleType ([ctvar entityName] ++
map (\ (ename,_) -> listType (ctvar ename))
manyToManyEntities)
)
([ctvar entityName] ++
[entityInterface (filter notKey attrlist)
manyToOneEntities manyToManyEntities])
)
[simpleRule
(
[ CPVar (1, lowerFirst entityName ++ "ToUpdate"),
tuplePattern
(
(map (\ ((Attribute name _ _ _), varId) ->
CPVar (varId,lowerFirst name)))
(zip (filter notKey attrlist) [1..]) ++
(map (\ (name, varId) -> CPVar(varId,lowerFirst name))
(zip manyToOneEntities [1..])) ++
(map (\ ((ename,erel), varId) ->
CPVar (varId, lowerFirst $ erel ++ ename ++ "s"))
(zip manyToManyEntities [1..]))
)
]
)
(tupleExpr $
(foldr (\ (Attribute aname domain _ _) expr ->
case domain of
KeyDom rel ->
applyF (model erdname, "set" ++ entityName ++ aname)
[expr,
applyF (model erdname, lowerFirst rel ++ "Key")
[CVar (1, lowerFirst rel)]]
_ -> applyF (model erdname, "set" ++ entityName ++ aname)
[expr, CVar (1, lowerFirst aname)] )
(CVar (0, lowerFirst $ entityName++"ToUpdate"))
attrlist )
: (map (\ (ename,erel) -> cvar (lowerFirst $ erel ++ ename ++ "s"))
manyToManyEntities))]
entity2Tuple :: ViewGenerator
entity2Tuple erdname (Entity entityName attrlist) relationships allEntities =
let
manyToManyEntities = manyToMany allEntities (Entity entityName attrlist)
manyToOneEntities = manyToOne (Entity entityName attrlist) relationships
in
stCmtFunc
("Transformation from entity type "++entityName++" to a tuple\n"++
"which can be used in WUI specifications.")
(viewModuleName entityName, (lowerFirst entityName)++"2Tuple") 2 Public
(
foldr (CFuncType)
(entityInterface (filter notKey attrlist)
manyToOneEntities manyToManyEntities)
(
(map ctvar manyToOneEntities) ++
[(if null manyToManyEntities
then baseType (model erdname, entityName)
else tupleType
([ctvar entityName] ++
map (\ (name,_) -> listType (ctvar name))
manyToManyEntities)
)]
)
)
[simpleRule
(
(map (\ (name, varId) -> CPVar(varId,(lowerFirst name)))
(zip manyToOneEntities [1..])) ++
[
tuplePattern
(
CPVar (1, lowerFirst entityName) :
(map (\ ((ename,erel), varId) ->
CPVar (varId, lowerFirst $ erel ++ ename ++ "s"))
(zip manyToManyEntities [1..]))
)
]
)
(tupleExpr
(map (\ (Attribute a _ _ _) ->
applyF (model erdname, lowerFirst entityName ++ a)
[cvar (lowerFirst entityName)])
(filter notKey attrlist) ++
map (\e -> cvar (lowerFirst e)) manyToOneEntities ++
map (\ (ename,erel) -> cvar (lowerFirst $ erel ++ ename ++ "s"))
manyToManyEntities)
)]
wuiType :: ViewGenerator
wuiType _ (Entity entityName attrlist) relationships allEntities =
let
manyToManyEntities = manyToMany allEntities (Entity entityName attrlist)
manyToOneEntities = manyToOne (Entity entityName attrlist) relationships
possibleVars vart =
map (\ (ename,erel) -> vart (1, lowerFirst $ erel ++ ename ++ "List"))
(map (\n -> (n,"")) manyToOneEntities ++ manyToManyEntities)
in
stCmtFunc
("WUI Type for editing or creating "++entityName++" entities.\n"++
"Includes fields for associated entities.")
(viewModuleName entityName, "w"++entityName++"Type") 2 Public
(
foldr CFuncType
(applyTC (wuiModule "WuiSpec") [
if null manyToManyEntities
then ctvar entityName
else
tupleType ([ctvar entityName] ++
map (\ (name,_) -> listType (ctvar name))
manyToManyEntities)
])
(
[ctvar entityName] ++
(map ctvar manyToOneEntities) ++ -- related values
(map (listType . ctvar) -- possible values
(manyToOneEntities ++ map fst manyToManyEntities))
)
)
[simpleRule
(
[CPVar (1, lowerFirst entityName)] ++
(map (\e -> CPVar (1, lowerFirst e)) manyToOneEntities) ++ -- related values
(possibleVars CPVar)
)
(applyF (wuiModule "transformWSpec") [
tupleExpr
[
applyF (viewModuleName entityName, "tuple2"++entityName)
[cvar (lowerFirst entityName)],
applyF (viewModuleName entityName,lowerFirst entityName++"2Tuple")
(map (\e -> CVar (1, lowerFirst e)) (manyToOneEntities))
],
applyF (viewModuleName entityName, "w"++entityName)
(possibleVars CVar)
]
)]
-- Generate function to compare to entities in lexicographic order.
-- To avoid useless component comparisons, only the first five non-key
-- attributes are used for the comparison.
leqEntity :: ViewGenerator
leqEntity erdname (Entity entityName attrlist) _ _ =
stCmtFunc
("Compares two "++entityName++" entities. This order is used in the list view.")
(viewModuleName entityName, "leq" ++ entityName) 2 Private
-- function type
(baseType (model erdname,entityName) ~> baseType (model erdname,entityName)
~> boolType)
[let ename = lowerFirst entityName
e1 = (1,"x1")
e2 = (2,"x2")
in simpleRule [CPVar e1,CPVar e2]
(applyF (pre "<=")
[tupleExpr (map (\ (Attribute a _ _ _) ->
applyF (model erdname,ename++a) [CVar e1])
(take 5 (filter notKey attrlist))),
tupleExpr (map (\ (Attribute a _ _ _) ->
applyF (model erdname,ename++a) [CVar e2])
(take 5 (filter notKey attrlist)))
])]
-- generate view for showing entities
showView :: ViewGenerator
showView erdname (Entity entityName attrlist) relationships allEntities =
let manyToManyEntities = manyToMany allEntities (Entity entityName attrlist)
manyToOneEntities = manyToOne (Entity entityName attrlist) relationships
infovar = (0, "_")
evar = (1, lowerFirst entityName)
mmRelatedVars vart =
map (\ ((ename,erel), i) -> vart (i, lowerFirst $ erel ++ ename ++ "s"))
(zip manyToManyEntities [(length manyToOneEntities + 3) ..])
in viewFunction
("Supplies a view to show the details of a "++entityName++".\n")
entityName "show" 2
-- function type
(userSessionInfoType ~>
foldr CFuncType viewBlockType (
[baseType (model erdname,entityName)] ++
(map ctvar manyToOneEntities) ++ -- defaults for n:1
(map (\ (name,_) -> listType (ctvar name)) manyToManyEntities))
)
[simpleRule
( -- parameters
[CPVar infovar, CPVar evar] ++
(map (\ (name, varId) -> CPVar (varId,"related"++name))
(zip manyToOneEntities [3..])) ++
(mmRelatedVars CPVar)
)
(applyF (pre "++")
[applyF (entitiesToHtmlModule erdname,
lowerFirst entityName++"ToDetailsView")
([CVar evar] ++
map (\ (name, varId) -> CVar (varId,"related"++name))
(zip manyToOneEntities [3..]) ++
mmRelatedVars CVar
),
list2ac [applyF hrefButtonName
[applyF (spiceyModule,"listRoute") [CVar evar],
list2ac [applyF (html "htxt")
[string2ac ("To " ++ entityName ++ " list")]]]]
]
)]
--- Create operation for the "list entities" view.
listView :: ViewGenerator
listView erdname (Entity entityName attrlist) _ _ =
viewFunction
("Supplies a list view for a given list of "++entityName++" entities.\n"++
"Shows also show/edit/delete buttons if the user is logged in.\n"++
"The arguments are the session info and the list of "++entityName++
" entities.\n")
entityName "list" 1
-- function type
(userSessionInfoType ~> listType (baseType (model erdname,entityName))
~> viewBlockType)
[CRule
[CPVar infovar, CPVar entsvar]
(CSimpleRhs
(applyF (pre ":") [
applyF (html "h1")
[list2ac [applyF (html "htxt")
[string2ac $ entityName ++ " list"]]],
list2ac [
applyF (spiceyModule, "spTable") [
applyF (pre "++") [
list2ac [
applyF (pre "take") [
CLit (CIntc (length attrlist)),
constF (entitiesToHtmlModule erdname,
lowerFirst entityName ++ "LabelList")
]
],
applyF (pre "map") [
constF (viewModuleName entityName,"list" ++ entityName),
applyF (listModule,"sortBy") [
constF (viewModuleName entityName,"leq" ++ entityName),
CVar entsvar
]
]
]
]
]
]
)
[CLocalFunc (stFunc
(viewModuleName entityName, "list"++entityName) 2 Private
(ctvar entityName ~> listType viewBlockType)
[simpleRule [CPVar envar]
(applyF (pre "++") [
applyF (entitiesToHtmlModule erdname,
lowerFirst entityName++"ToListView")
[cvar $ lowerFirst entityName],
ifThenElseExp
(applyF (pre "==")
[applyF (sessionInfoModule,"userLoginOfSession")
[CVar infovar],
constF (pre "Nothing")])
(list2ac [])
(list2ac
[list2ac
[applyF hrefSmallButtonName
[applyF (spiceyModule,"showRoute") [CVar envar],
list2ac [applyF (html "htxt") [string2ac "Show"]]]],
list2ac
[applyF hrefSmallButtonName
[applyF (spiceyModule,"editRoute") [CVar envar],
list2ac [applyF (html "htxt") [string2ac "Edit"]]]],
list2ac
[applyF hrefSmallButtonName
[applyF (spiceyModule,"deleteRoute") [CVar envar],
list2ac [applyF (html "htxt") [string2ac "Delete"]]]]])
]
)])
])
]
where
infovar = (0, "sinfo")
entsvar = (1, lowerFirst entityName ++ "s")
envar = (2, lowerFirst entityName)
-- Auxiliaries
-- entityName: Name of entity the view should be generated for
-- viewType: the function of the generated View, e.g. "new", "edit", "list"
-- arity
-- functionType: the type of the view function
-- rules: the rules defining the view
viewFunction :: String -> String -> String -> Int -> CTypeExpr -> [CRule]
-> CFuncDecl
viewFunction description entityName viewType arity functionType rules =
stCmtFunc description (viewFunctionName entityName viewType) arity
Public functionType rules
entityInterface :: [Attribute] -> [String] -> [(String,String)] -> CTypeExpr
entityInterface attrlist manyToOne manyToMany =
tupleType (map attrType attrlist ++
map ctvar manyToOne ++
map (\ (e,_) -> listType (ctvar e)) manyToMany)
|