Controller generation refactored

resource_files/Spicey.curry

@@ -7,12 +7,13 @@ module System.Spicey (
   module System, 
   module HTML.Base, 
   module ReadNumeric, 
-  Controller, applyControllerOn,
-  nextController, nextControllerForData, confirmNextController,
-  confirmController, transactionController,
+  Controller, EntityController(..), applyControllerOn,
+  nextController, nextControllerForData,
+  confirmDeletionPage,
+  transactionController,
   getControllerURL,getControllerParams, showControllerURL,
   getForm, wDateType, wBoolean, wUncheckMaybe, wFloat,
-  displayError, cancelOperation,
+  displayError, displayUrlError, cancelOperation,
   renderWuiForm, renderLabels,
   nextInProcessOr,
   stringToHtml, maybeStringToHtml,
@@ -58,10 +59,16 @@ type ViewBlock = [HtmlExp]
 --- Spicey.getControllerParams inside the controller.
 type Controller = IO ViewBlock
 
+--- The type class `EntityController` provides the application
+--- of a controller to some entity identified by a key string.
+class EntityController a where
+  controllerOnKey :: String -> (a -> Controller) -> Controller
+
+
 --- Reads an entity for a given key and applies a controller to it.
 applyControllerOn :: Maybe enkey -> (enkey -> IO en)
                   -> (en -> Controller) -> Controller
-applyControllerOn Nothing _ _ = displayError "Illegal URL"
+applyControllerOn Nothing _ _ = displayUrlError
 applyControllerOn (Just userkey) getuser usercontroller =
   getuser userkey >>= usercontroller
 
@@ -76,23 +83,24 @@ nextControllerForData controller param = do
   view <- controller param
   getForm view
 
---- Call the next controller after a user confirmation.
---- The Boolean user answer is passed as an argument to the controller.
-confirmNextController :: HtmlExp -> (Bool -> Controller) -> _ -> IO HtmlForm
-confirmNextController question controller _ = do
-  getForm [question,
-           defaultButton "Yes" (nextController (controller True)),
-           defaultButton "No"  (nextController (controller False))]
-
---- Ask the user for a confirmation and call the corresponding controller.
+--- Generates a page to ask the user for a confirmation to delete an entity
+--- specified in the controller URL (of the form "entity/delete/key/...").
+--- The yes/no answers are references derived from the controller URL
+--- where the second argument is replaced by "destroy"/"show".
 --- @param question - a question asked
 --- @param yescontroller - the controller used if the answer is "yes"
 --- @param nocontroller  - the controller used if the answer is "no"
-confirmController :: [HtmlExp] -> Controller -> Controller -> Controller
-confirmController question yescontroller nocontroller = do
-  return $ question ++
-           [par [defaultButton "Yes" (nextController yescontroller),
-                 defaultButton "No"  (nextController nocontroller )]]
+confirmDeletionPage :: UserSessionInfo -> String -> Controller
+confirmDeletionPage _ question = do
+  (entity,ctrlargs) <- getControllerURL
+  case ctrlargs of
+    (_:args) -> return $
+      [h3 [htxt question],
+       par [hrefButton (showControllerURL entity ("destroy":args)) [htxt "Yes"],
+            nbsp,
+            hrefButton (showControllerURL entity ("show" : args)) [htxt "No"]]]
+    _ -> displayUrlError
+
 
 --- A controller to execute a transaction and proceed with a given
 --- controller if the transaction succeeds. Otherwise, the
@@ -301,6 +309,10 @@ displayError msg = do
    then return [htxt "General error (shown by function Spicey.displayError)"]
    else return [htxt msg]
 
+--- A controller to display an URL error.
+displayUrlError :: Controller
+displayUrlError = displayError "Illegal URL"
+
 -- like renderTaggedTuple from WUI Library but takes list of HtmlExp
 -- instead of list of strings
 renderLabels :: [[HtmlExp]] -> Rendering

src/Spicey/ControllerGeneration.curry

@@ -23,51 +23,75 @@ generateControllersForEntity :: String -> [Entity] -> Entity
                              -> [Relationship]
                              -> CurryProg
 generateControllersForEntity erdname allEntities
-                             (Entity ename attrlist) relationships =
- simpleCurryProg
+                             entity@(Entity ename _) relationships =
+ CurryProg
   (controllerModuleName ename)
   -- imports:
-  [ spiceyModule, "HTML.Base", "Time"
-  , erdname, viewModuleName ename
-  , "Maybe", sessionInfoModule, authorizationModule, enauthModName
-  , "Config.UserProcesses",
-   entitiesToHtmlModule erdname]
-  [] -- typedecls
+  [ "Maybe", "Time", "HTML.Base"
+  , erdname
+  , "Config.UserProcesses"
+  , sessionInfoModule, authorizationModule, enauthModName, spiceyModule
+  , entitiesToHtmlModule erdname
+  , viewModuleName ename
+  ]
+  Nothing -- defaultdecl
+  [] -- classdecls
+  [controllerInstDecl erdname entity] -- instdecls
+  [newEntityType erdname entity relationships allEntities] -- typedecls
   -- functions
   (
     [
      -- controller for dispatching to various controllers:
-     mainController erdname (Entity ename attrlist) relationships allEntities,
+     mainController erdname entity relationships allEntities,
      -- controller for providing a page to enter new entity data:
-     newController erdname (Entity ename attrlist) relationships allEntities,
+     newController erdname entity relationships allEntities,
      -- transaction for saving data in new entity:
-     createTransaction erdname (Entity ename attrlist)
-                               relationships allEntities,
+     createTransaction erdname entity relationships allEntities,
      -- controller to show an existing record in a form to edit
-     editController erdname (Entity ename attrlist) relationships allEntities,
+     editController erdname entity relationships allEntities,
      -- transaction to update a record with the given data
-     updateTransaction erdname (Entity ename attrlist)
-                               relationships allEntities,
+     updateTransaction erdname entity relationships allEntities,
      -- controller to delete an entity with the given data
-     deleteController erdname (Entity ename attrlist)
-                              relationships allEntities,
+     deleteController erdname entity relationships allEntities,
+     -- controller to destroy an entity with the given data
+     destroyController erdname entity relationships allEntities,
      -- transaction to delete an entity with the given data
-     deleteTransaction erdname (Entity ename attrlist)
-                               relationships allEntities,
+     deleteTransaction erdname entity relationships allEntities,
      -- controller to list all entities:
-     listController erdname (Entity ename attrlist) relationships allEntities,
+     listController erdname entity relationships allEntities,
      -- controller to show entites:
-     showController erdname (Entity ename attrlist) relationships allEntities
+     showController erdname entity relationships allEntities
    ] ++ 
-    (manyToManyAddOrRemove erdname (Entity ename attrlist) (manyToMany allEntities (Entity ename attrlist)) allEntities) ++
-    --(getAll erdname (Entity ename attrlist) (manyToOne (Entity ename attrlist) relationships) allEntities) ++
-    --(getAll erdname (Entity ename attrlist) (manyToMany allEntities (Entity ename attrlist)) allEntities) ++
-    --(manyToManyGetRelated erdname (Entity ename attrlist) (manyToMany allEntities (Entity ename attrlist)) allEntities) ++
-    (manyToOneGetRelated erdname (Entity ename attrlist) (manyToOne (Entity ename attrlist) relationships) allEntities relationships)
+   manyToManyAddOrRemove erdname entity (manyToMany allEntities entity)
+                         allEntities ++
+    --(getAll erdname entity (manyToOne entity relationships) allEntities) ++
+    --(getAll erdname entity (manyToMany allEntities entity) allEntities) ++
+    --(manyToManyGetRelated erdname entity (manyToMany allEntities entity) allEntities) ++
+    manyToOneGetRelated erdname entity (manyToOne entity relationships)
+                        allEntities relationships
   )
   [] -- opdecls
 
 
+-- Generates the instance declaration for a controller.
+controllerInstDecl :: String -> Entity -> CInstanceDecl
+controllerInstDecl erdname (Entity entityName _) =
+  CInstance (spiceyModule,"EntityController")
+            (CContext [])
+            (baseType (erdname, entityName))
+    [cfunc (spiceyModule,"controllerOnKey") 1 Private
+      (CQualType (CContext [((spiceyModule,"EntityController"),tvara)])
+         (stringType ~> (tvara ~> controllerType) ~> controllerType))
+        [simpleRule [CPVar (2,"s")]
+                    (applyF (spiceyModule,"applyControllerOn")
+                            [readKey, getEntityOp])]]
+ where
+  tvara       = CTVar (0,"a")
+  readKey     = applyF (erdname, "read" ++ entityName ++ "Key") [CVar (2,"s")]
+  getEntityOp = applyF (pre ".")
+                       [constF (erdname, "runJustT"),
+                        constF (erdname, "get" ++ entityName)]
+
 -- erdname: name of the entity-relationship-specification
 -- entity: the entity to generate a controller for
 type ControllerGenerator = String -> Entity -> [Relationship] -> [Entity] -> CFuncDecl
@@ -75,7 +99,7 @@ type ControllerGenerator = String -> Entity -> [Relationship] -> [Entity] -> CFu
 -- Generates the main controller that dispatches to the various
 -- subcontrollers according to the URL parameters.
 mainController :: ControllerGenerator
-mainController erdname (Entity entityName _) _ _ =
+mainController _ (Entity entityName _) _ _ =
   controllerFunction 
   ("Choose the controller for a "++entityName++
    " entity according to the URL parameter.")
@@ -92,33 +116,32 @@ mainController erdname (Entity entityName _) _ _ =
               cBranch (listPattern [stringPattern "list"])
                       (constF (controllerFunctionName entityName "list")),
               cBranch (listPattern [stringPattern "new"])
-                      (constF (controllerFunctionName entityName "new")),
-              cBranch (listPattern [stringPattern "show", CPVar (2,"s")])
-                (applyF (spiceyModule,"applyControllerOn")
-                  [readKey,
-                   getEntityOp,
-                   constF (controllerFunctionName entityName "show")]),
-              cBranch (listPattern [stringPattern "edit", CPVar (2,"s")])
-                (applyF (spiceyModule,"applyControllerOn")
-                  [readKey,
-                   getEntityOp,
-                   constF (controllerFunctionName entityName "edit")]),
-              cBranch (listPattern [stringPattern "delete", CPVar (2,"s")])
-                (applyF (spiceyModule,"applyControllerOn")
-                  [readKey,
-                   getEntityOp,
-                   constF (controllerFunctionName entityName "delete")]),
-              cBranch (CPVar (3,"_"))
-                 (applyF (spiceyModule, "displayError")
-                         [string2ac "Illegal URL"])])
+                      (constF (controllerFunctionName entityName "new"))] ++
+              map applyControllerBranch ["show", "edit", "delete", "destroy"] ++
+             [cBranch (CPVar (3,"_"))
+                      (constF (spiceyModule, "displayUrlError"))])
           )
          ]
       )]
  where
-  readKey     = applyF (erdname,"read"++entityName++"Key") [CVar (2,"s")]
-  getEntityOp = applyF (pre ".")
-                       [constF (erdname,"runJustT"),
-                        constF (erdname,"get"++entityName)]
+  applyControllerBranch n = let svar = (2,"s") in
+    cBranch (listPattern [stringPattern n, CPVar svar])
+            (applyF (spiceyModule,"controllerOnKey")
+                    [CVar svar, constF (controllerFunctionName entityName n)])
+
+--- Generates a type alias for a "new entity" tuple type which is
+--- used to create and insert new entities (without an entity key).
+newEntityType :: String -> Entity -> [Relationship] -> [Entity] -> CTypeDecl
+newEntityType erdname (Entity entityName attrList) relationships allEntities =
+  let notGeneratedAttributes = filter (\attr -> not (isForeignKey attr)
+                                                && notPKey attr)
+                                      attrList
+      manyToManyEntities = manyToMany allEntities (Entity entityName attrList)
+      manyToOneEntities  = manyToOne (Entity entityName attrList) relationships
+  in CTypeSyn (newEntityTypeName entityName) Private []
+       (tupleType (map attrType notGeneratedAttributes ++
+                   map ctvar manyToOneEntities ++
+                   map (listType . ctvar) manyToManyEntities))
 
 -- generates a controller to show a form to create a new entity
 -- the input is then passed to the create controller
@@ -197,10 +220,8 @@ createTransaction erdname (Entity entityName attrList) relationships allEntities
     ("Transaction to persist a new "++entityName++" entity to the database.")
     (transFunctionName entityName "create")
     1 Private
-      (tupleType (map attrType notGeneratedAttributes ++
-                  map ctvar manyToOneEntities ++
-                  map (listType . ctvar) manyToManyEntities)
-        ~> applyTC (dbconn "DBAction") [baseType (pre "()")])
+      (baseType (newEntityTypeName entityName)
+        ~> applyTC (dbconn "DBAction") [unitType])
       [simpleRule 
         [tuplePattern
           (map (\ (param, varId) -> CPVar (varId, param)) 
@@ -365,38 +386,52 @@ updateTransaction erdname (Entity entityName attrList) _ allEntities =
 --- Generates controller to delete an entity after confirmation.
 deleteController :: ControllerGenerator
 deleteController erdname (Entity entityName _) _ _ =
-  let entlc  = lowerFirst entityName  -- entity name in lowercase
-      entvar = (0, entlc)             -- entity parameter for controller
+  let entlc    = lowerFirst entityName  -- entity name in lowercase
+      entvar   = (0, entlc)             -- entity parameter for controller
+      sinfovar = (1, "sinfo")           -- "sinfo" parameter
   in
   controllerFunction
   ("Deletes a given "++entityName++" entity (after asking for confirmation)\n"++
    "and proceeds with the list controller.")
   entityName "delete" 1
   (baseType (erdname, entityName) ~> controllerType)
+  [simpleRule [CPVar entvar]
+    (applyF (pre "$")
+       [applyF checkAuthorizationFunc
+         [applyF (enauthModName,entlc++"OperationAllowed")
+                 [applyF (authorizationModule,"DeleteEntity") [CVar entvar]]],
+        CLambda [CPVar sinfovar] $
+         applyF (spiceyModule,"confirmDeletionPage")
+                [CVar sinfovar,
+                 applyF (pre "concat")
+                   [list2ac [string2ac "Really delete entity \"",
+                             applyF (entitiesToHtmlModule erdname,
+                                     entlc ++ "ToShortView")
+                                    [CVar entvar],
+                             string2ac "\"?"]]]])]
+
+--- Generates controller to delete an entity.
+destroyController :: ControllerGenerator
+destroyController erdname (Entity entityName _) _ _ =
+  let entlc  = lowerFirst entityName  -- entity name in lowercase
+      entvar = (0, entlc)             -- entity parameter for controller
+  in
+  controllerFunction
+  ("Deletes a given " ++ entityName ++ " entity\n" ++
+   "and proceeds with the list controller.")
+  entityName "destroy" 1
+  (baseType (erdname, entityName) ~> controllerType)
   [simpleRule [CPVar entvar]
     (applyF (pre "$")
        [applyF checkAuthorizationFunc
          [applyF (enauthModName,entlc++"OperationAllowed")
                  [applyF (authorizationModule,"DeleteEntity") [CVar entvar]]],
         CLambda [CPVar (0,"_")] $
-         applyF (spiceyModule,"confirmController")
-         [list2ac
-           [applyF (html "h3")
-             [list2ac
-               [applyF (html "htxt")
-                [applyF (pre "concat")
-                 [list2ac [string2ac "Really delete entity \"",
-                           applyF (entitiesToHtmlModule erdname,
-                                   entlc++"ToShortView")
-                                  [CVar entvar],
-                           string2ac "\"?"]]]]]],
-          applyF (spiceyModule,"transactionController")
+         applyF (spiceyModule,"transactionController")
             [applyF (erdname,"runT")
                     [applyF (transFunctionName entityName "delete")
                             [CVar entvar]],
-             constF (controllerFunctionName entityName "list")],
-          applyF (controllerFunctionName entityName "show")
-                 [CVar entvar]]])]
+             constF (controllerFunctionName entityName "list")]])]
 
 --- Generates a transaction to delete an entity.
 deleteTransaction :: ControllerGenerator

src/Spicey/GenerationHelper.curry

@@ -147,6 +147,11 @@ controllerType = baseType (spiceyModule,"Controller")
 controllerModuleName :: String -> String
 controllerModuleName entityName = "Controller." ++ entityName
 
+--- The name of the type synonym for a "new entity" tuple.
+newEntityTypeName :: String -> QName
+newEntityTypeName entityName =
+  (controllerModuleName entityName, "New" ++ entityName)
+  
 --- The name of the controller function for a given entity and controller
 --- functionality.
 controllerFunctionName :: String -> String -> QName

src/Spicey/SpiceUp.curry

@@ -16,7 +16,7 @@ import Spicey.Scaffolding
 systemBanner :: String
 systemBanner =
   let bannerText = "Spicey Web Framework (Version " ++ packageVersion ++
-                   " of 25/11/18)"
+                   " of 20/10/19)"
       bannerLine = take (length bannerText) (repeat '-')
    in bannerLine ++ "\n" ++ bannerText ++ "\n" ++ bannerLine