module Spicey.EntitiesToHtmlGeneration where
import AbstractCurry.Types
import AbstractCurry.Build
import Database.ERD
import Database.ERD.Goodies
import Spicey.GenerationHelper
-- "main"-function
generateToHtml :: String -> [Entity] -> [Relationship] -> CurryProg
generateToHtml erdname allEntities relationships = simpleCurryProg
(entitiesToHtmlModule erdname)
["WUI", "HTML.Base", "Time", spiceyModule, erdname] -- imports
[] -- typedecls
-- functions
(
foldr1 (++) (map (\e -> generateToHtmlForEntity erdname allEntities e relationships)
(filter (not . Spicey.GenerationHelper.isGenerated)
allEntities))
)
[]
generateToHtmlForEntity :: String -> [Entity] -> Entity -> [Relationship] -> [CFuncDecl]
generateToHtmlForEntity erdname allEntities (Entity ename attrlist) relationships =
[toListView erdname (Entity ename (filter noKeyAttr attrlist)) relationships allEntities,
toShortView erdname (Entity ename (filter noKeyAttr attrlist)) relationships allEntities,
toDetailsView erdname (Entity ename (filter noKeyAttr attrlist)) relationships allEntities,
labelList erdname (Entity ename (filter noKeyAttr attrlist)) relationships allEntities
]
where
noKeyAttr a = (notKey a) && (notPKey a)
type ToHtmlGenerator = String -> Entity -> [Relationship] -> [Entity] -> CFuncDecl
toListView :: ToHtmlGenerator
toListView erdname (Entity entityName attrlist) _ _ =
stCmtFunc
("The list view of a "++entityName++" entity in HTML format.\n"++
"This view is used in a row of a table of all entities.")
(thisModuleName erdname, (lowerFirst entityName)++"ToListView") 2 Public
(baseType (erdname, entityName)
~> listType (listType (baseType (html "HtmlExp"))))
[simpleRule [CPVar (1, lowerFirst entityName)]
(list2ac (
(map (\a -> list2ac [
applyF (attributeToConverter a) [
applyF (erdname, (lowerFirst entityName)++(attributeName a)) [
cvar (lowerFirst entityName)
]
]
]
)
attrlist
)
)
)]
toShortView :: ToHtmlGenerator
toShortView erdname (Entity entityName attrlist) _ _ =
stCmtFunc
("The short view of a "++entityName++" entity as a string.\n"++
"This view is used in menus and comments to refer to a "++entityName++" entity.")
(thisModuleName erdname, (lowerFirst entityName)++"ToShortView")
2
Public
(baseType (erdname, entityName) ~> stringType)
[simpleRule [CPVar (1,eName)]
(case attributeDomain firstKeyAttribute of
StringDom _ -> accessFirstKeyAttribute
_ -> applyF (pre "show") [accessFirstKeyAttribute]
)]
where
eName = lowerFirst entityName
accessFirstKeyAttribute =
applyF (erdname, eName++attributeName firstKeyAttribute) [cvar eName]
firstKeyAttribute = findKeyAttribute attrlist attrlist
findKeyAttribute (attr@(Attribute _ _ key _):attrList) fullList =
if key== Unique then attr
else findKeyAttribute attrList fullList
findKeyAttribute [] fullList = head fullList
toDetailsView :: ToHtmlGenerator
toDetailsView erdname (Entity entityName attrlist) relationships allEntities =
let manyToManyEntities = manyToMany allEntities (Entity entityName attrlist)
manyToOneEntities = manyToOne (Entity entityName attrlist) relationships
eName = lowerFirst entityName
evar = (1,eName)
in
stCmtFunc
("The detailed view of a "++entityName++" entity in HTML format.\n"++
if null (manyToOneEntities ++ manyToManyEntities) then "" else
"It also takes associated entities for every associated entity type.")
(thisModuleName erdname, (lowerFirst entityName)++"ToDetailsView")
2
Public
-- function type
(foldr CFuncType (listType (baseType (html "HtmlExp")))
([baseType (erdname, entityName)] ++
(map ctvar manyToOneEntities) ++ -- defaults for n:1
(map (\name -> listType (ctvar name)) manyToManyEntities)
)
)
[CRule
( -- parameters
[CPVar evar] ++
map (\ (name, varId) -> CPVar (varId,"related"++name))
(zip manyToOneEntities [2..]) ++
map (\ (name, varId) -> CPVar (varId, lowerFirst name ++ "s"))
(zip manyToManyEntities [(length manyToOneEntities + 2)..])
)
(CSimpleRhs
(list2ac [
applyF (spiceyModule, "spTable") [
applyF (pre "map")
[
CLambda [tuplePattern [CPVar(2, "label"), CPVar(3, "value")]]
(list2ac [cvar "label", cvar "value"]),
applyF (pre "zip")
[constF (thisModuleName erdname, eName++"LabelList"),
CVar (2,"detailedView")]
]
]
]
)
[CLocalPat (CPVar (2,"detailedView"))
(CSimpleRhs
(list2ac
(map (\a -> list2ac [
applyF (attributeToConverter a)
[applyF (erdname, eName ++ attributeName a)
[CVar evar]]])
attrlist ++
map (\ (name,varId) ->
list2ac [applyF (html "htxt")
[applyF (thisModuleName erdname,
lowerFirst name ++ "ToShortView")
[CVar (varId,"related"++name)]]])
(zip manyToOneEntities [2..]) ++
map (\ (name,varId) ->
list2ac
[applyF (html "htxt")
[applyF (pre "unwords")
[applyF (pre "map")
[applyF (thisModuleName erdname,
lowerFirst name ++"ToShortView") [],
CVar (varId,lowerFirst name++"s")]]]])
(zip manyToManyEntities [(length manyToOneEntities + 2)..])
)
)
[])
])
]
labelList :: ToHtmlGenerator
labelList erdname (Entity entityName attrlist) relationships allEntities =
let
manyToManyEntities = manyToMany allEntities (Entity entityName attrlist)
manyToOneEntities = manyToOne (Entity entityName attrlist) relationships
in
stCmtFunc
("The labels of a "++entityName++" entity, as used in HTML tables.")
(thisModuleName erdname, (lowerFirst entityName)++"LabelList") 2 Public
(
listType (listType (baseType (html "HtmlExp")))
)
[simpleRule []
(list2ac (
(map (\ (Attribute name domain _ _) ->
list2ac [applyF (html "textstyle")
[string2ac ("spicey_label spicey_label_for_type_"++
domainToString domain),
string2ac name]])
attrlist) ++
(map (\s -> list2ac [applyF (html "textstyle")
[string2ac "spicey_label spicey_label_for_type_relation",
string2ac s]])
(manyToOneEntities++manyToManyEntities))
)
)]
thisModuleName :: String -> String
thisModuleName erdname = entitiesToHtmlModule erdname
attributeToConverter :: Attribute -> QName
attributeToConverter (Attribute _ domain _ isnull) =
(spiceyModule,
if isnull && not (isStringDom domain)
then "maybe" ++ upperFirst (domainToString domain) ++ "ToHtml"
else domainToString domain ++ "ToHtml")
domainToString :: Domain -> String
domainToString domain =
case domain of
IntDom _ -> "int"
FloatDom _ -> "float"
CharDom _ -> "char"
StringDom _ -> "string"
BoolDom _ -> "bool"
DateDom _ -> "calendarTime"
UserDefined _ _ -> "userDefined"
KeyDom _ -> "key"