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

module Spicey.RouteGeneration where

import AbstractCurry.Types
import AbstractCurry.Build
import Database.ERD
import Database.ERD.Goodies

import Spicey.ControllerGeneration
import Spicey.GenerationHelper

generateRoutesForERD :: ERD -> CurryProg
generateRoutesForERD (ERD _ entities _) =
 let spiceySysCtrl = "Controller.SpiceySystemController" in
 CurryProg
  mappingModuleName
  ([spiceyModule, "System.Routes", spiceySysCtrl, dataModuleName] ++
   (map (\e -> controllerModuleName (entityName e)) entities)) -- imports
  [] -- typedecls
  [
    cmtfunc
      ("Maps the controllers associated to URLs in module RoutesData\n"++
       "into the actual controller operations.")
      (mappingModuleName, "getController")
      1
      Public
      (baseType (mappingModuleName, "ControllerReference") ~> controllerType)
      [simpleRule [CPVar (1, "fktref")]
         (CCase CRigid (CVar (1, "fktref"))
              ( [cBranch (CPComb (dataModuleName, "ProcessListController") [])
                         (constF (spiceySysCtrl, "processListController")),
                 cBranch (CPComb (dataModuleName, "LoginController") [])
                         (constF (spiceySysCtrl, "loginController"))] ++
                map branchesForEntity entities ++
                [cBranch (CPVar (2,"_"))
                  (applyF (spiceyModule, "displayError")
                          [string2ac "getController: no mapping found"])]
              )
          )]
  ] -- functions
  [] -- opdecls

-- startpoint controller prefixes
controllerPrefixes :: [String]
controllerPrefixes = ["List","New"]

branchesForEntity :: Entity -> (CPattern, CRhs)
branchesForEntity (Entity entityName _) =
  let controllerReference = entityName ++ "Controller"
   in cBranch (CPComb ("RoutesData", controllerReference) [])
              (constF (controllerModuleName entityName,
                       "main" ++ controllerReference))

generateStartpointDataForERD :: ERD -> CurryProg
generateStartpointDataForERD (ERD _ entities _) = CurryProg
  dataModuleName
  [authenticationModule] -- imports
  [
    CType (dataModuleName, "ControllerReference") Public []
          ([CCons (dataModuleName, "ProcessListController") Public [],
            CCons (dataModuleName, "LoginController") Public []] ++
           map controllerReferencesForEntity entities),
    urlMatchType,
    routeType
  ] -- typedecls
  [cmtfunc
     ("This constant specifies the association of URLs to controllers.\n"++
      "Controllers are identified here by constants of type\n"++
      "ControllerReference. The actual mapping of these constants\n"++
      "into the controller operations is specified in the module\n"++
      "ControllerMapping.")
     (dataModuleName, "getRoutes")
     0
     Public
     (ioType routeMappingType)
     [simpleRule []
        (CDoExpr
          [CSPat (CPVar (1,"login"))
                 (constF (authenticationModule,"getSessionLogin")),
           CSExpr $ applyF (pre "return")
             [list2ac (
               [tupleExpr
                  [string2ac "Processes",
                   applyF (dataModuleName, "Exact")
                          [string2ac "spiceyProcesses"],
                   constF (dataModuleName, "ProcessListController")]
               ] ++
               concatMap startpointsForEntity entities ++
               [tupleExpr
                  [applyF (pre "maybe")
                          [string2ac "Login",
                           applyF (pre "const") [string2ac "Logout"],
                           CVar (1,"login")],
                   applyF (dataModuleName, "Exact") [string2ac "login"],
                   constF (dataModuleName, "LoginController")],
                tupleExpr
                  [string2ac "default",
                   constF (dataModuleName, "Always"),
                   constF (dataModuleName,
                           firstEntityName entities ++ "Controller")]
               ]
             )
            ]
         ]
        )]
  ] -- functions
  [] -- opdecls
 where
  firstEntityName :: [Entity] -> String
  firstEntityName ((Entity entityName _):_) = entityName
  firstEntityName [] = error "RouteGeneration.firstEntityName: empty list arg"

  route :: String -> String -> String -> String -> CExpr
  route desc url uparam controllerDef =
    tupleExpr [string2ac desc,
               applyF (dataModuleName, "Prefix")
                      [string2ac url, string2ac uparam],
               constF (dataModuleName, controllerDef)]

  startpointsForEntity :: Entity -> [CExpr]
  startpointsForEntity (Entity entityName _) =
    map (\pre -> route (pre ++ " " ++ entityName)
                       entityName
                       (lowerFirst pre)
                       (entityName ++ "Controller"))
        controllerPrefixes

  urlMatchType :: CTypeDecl
  urlMatchType =
    CType (dataModuleName, "UrlMatch") Public [] [
      CCons (dataModuleName, "Exact")   Public [stringType],
      CCons (dataModuleName, "Prefix")  Public [stringType,stringType],
      CCons (dataModuleName, "Matcher") Public [stringType ~> boolType],
      CCons (dataModuleName, "Always")  Public []
    ]

  routeMappingType :: CTypeExpr
  routeMappingType = listType (baseType (dataModuleName,"Route"))

  routeType :: CTypeDecl
  routeType =
    CTypeSyn (dataModuleName, "Route") Public []
      (tupleType [stringType,
                  baseType (dataModuleName, "UrlMatch"),
                  baseType (dataModuleName, "ControllerReference")])

  controllerReferencesForEntity :: Entity -> CConsDecl
  controllerReferencesForEntity (Entity entityName _) =
    CCons (dataModuleName, entityName++"Controller") Public []