1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
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)
  [ "Sort", "Time"
  , "HTML.Base", bootstrapModule, "HTML.WUI"
  , 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 ++ 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))
                (manyToOneEntities ++ manyToManyEntities))-- possible values
    )
    [simpleRule (map (\e -> CPVar (1, lowerFirst $ e ++ "List"))
                     (manyToOneEntities ++ manyToManyEntities))
       (applyF (wuiModule "withRendering") [
            (if (argumentCount == 1) then
              head (attrWidgets attrlist)
            else
              applyF (combinator argumentCount)
               ( attrWidgets attrlist ++
                 map (\e -> applyF (wuiModule "wSelect")
                              [constF (erdname, lowerFirst e++"ToShortView"),
                               CVar (1, lowerFirst $ e ++ "List")])
                     manyToOneEntities ++
                 map (\e ->
                  applyF (wuiModule "wMultiCheckSelect")
                   [CLambda [CPVar (1, lowerFirst e)]
                      (list2ac [
                        applyF (html "htxt") [
                         applyF (erdname, lowerFirst e++"ToShortView")
                                [CVar (1, lowerFirst e)]
                         ]]),
                    CVar (1, lowerFirst $ e ++ "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 (erdname, entityName)
       else tupleType ([ctvar entityName] ++
                       map (\name -> listType (ctvar name)) 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 (\ (name, varId) -> CPVar(varId,lowerFirst $ name++"s"))
                 (zip manyToManyEntities [1..]))
           )
        ]
      )
      (tupleExpr $
         (foldr (\ (Attribute aname domain _ _) expr ->
                   case domain of
                     (KeyDom rel) ->
                       applyF (erdname, "set"++entityName++aname)
                              [expr,
                               applyF (erdname, (lowerFirst rel)++"Key")
                                      [CVar (1, lowerFirst rel)]]
                     _ -> applyF (erdname, "set"++entityName++aname)
                                 [expr,  CVar (1, lowerFirst aname)]  )

                 (CVar (0, lowerFirst $ entityName++"ToUpdate"))
                 attrlist )
            : (map (\e -> cvar (lowerFirst $ e ++ "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 (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 (\ (name, varId) -> CPVar(varId,(lowerFirst $ name++"s")))
                 (zip manyToManyEntities [1..]))
          )
        ]
      )
      (tupleExpr
            (map (\ (Attribute a _ _ _) ->
                     applyF (erdname, (lowerFirst entityName)++a)
                            [cvar (lowerFirst entityName)])
                  (filter notKey attrlist) ++
             map (\e -> cvar (lowerFirst e)) manyToOneEntities ++
             map (\e -> cvar (lowerFirst $ e ++ "s")) manyToManyEntities)
        )]

wuiType :: ViewGenerator
wuiType _ (Entity entityName attrlist) relationships allEntities =
  let
    manyToManyEntities = manyToMany allEntities (Entity entityName attrlist)
    manyToOneEntities  = manyToOne (Entity entityName attrlist) relationships
  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 (\e -> ctvar e) (manyToOneEntities)) ++ -- related values
        --(map (\e -> listType (ctvar e)) manyToManyEntities) ++ -- related values
        (map (\e -> listType (ctvar e))
             (manyToOneEntities ++ manyToManyEntities))-- possible values
      )
    )
    [simpleRule
      (
        [CPVar (1, lowerFirst entityName)] ++
        (map (\e -> CPVar (1, lowerFirst e)) manyToOneEntities) ++ -- related values
        --(map (\e -> CPVar (1, lowerFirst $ e++"s")) (manyToManyEntities)) ++ -- related values
        (map (\e -> CPVar (1, lowerFirst $ e++"List"))
             (manyToOneEntities ++ manyToManyEntities))
      )
      (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)
                   (map (\e -> CVar (1, lowerFirst $ e ++ "List"))
                        (manyToOneEntities ++ manyToManyEntities))
          ]
        )]


-- 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 (erdname,entityName) ~> baseType (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 (erdname,ename++a) [CVar e1])
                                   (take 5 (filter notKey attrlist))),
                    tupleExpr (map (\ (Attribute a _ _ _) ->
                                       applyF (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)
  in viewFunction
      ("Supplies a view to show the details of a "++entityName++".\n")
      entityName "show" 2
      -- function type
      (userSessionInfoType ~>
       foldr CFuncType viewBlockType (
          [baseType (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..])) ++
          (map (\ (name, varId) -> CPVar (varId, lowerFirst name ++ "s"))
               (zip manyToManyEntities [(length manyToOneEntities + 3)..]))
        )
        (applyF (pre "++")
              [applyF (entitiesToHtmlModule erdname,
                       lowerFirst entityName++"ToDetailsView")
                  ([CVar evar] ++
                   map (\ (name, varId) -> CVar (varId,"related"++name))
                       (zip manyToOneEntities [3..]) ++
                   map (\ (name, varId) -> CVar (varId, lowerFirst name++"s"))
                       (zip manyToManyEntities
                            [(length manyToOneEntities + 3)..])
                  ),
               list2ac [applyF hrefButtonName
                         [string2ac ("?" ++ entityName ++ "/list"),
                          list2ac [applyF (html "htxt")
                            [string2ac ("back 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 (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 ("Sort","mergeSortBy") [
                        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],
              applyF (pre "if_then_else")
               [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] -> CTypeExpr
entityInterface attrlist manyToOne manyToMany =
  tupleType (map attrType attrlist ++
             map ctvar manyToOne ++
             map (\e -> listType (ctvar e)) manyToMany)