{-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-}

module Spicey.ControllerGeneration where

import Data.Char ( toLower )
import Debug.Trace
import AbstractCurry.Types
import AbstractCurry.Build
import Database.ERD
import Database.ERD.Goodies

import Spicey.GenerationHelper

-- Name of entity-specific authorization module:
enauthModName :: String
enauthModName = "System.AuthorizedActions"

-- Name of module defining the default controller:
defCtrlModName :: String
defCtrlModName = "Controller.DefaultController"

-- "main"-function
generateControllersForEntity :: String -> [Entity] -> Entity -> [Relationship]
                             -> CurryProg
generateControllersForEntity erdname allEntities
                             entity@(Entity ename attrlist) relationships =
 let noKeyAttrs = filter (\a -> notKey a && notPKey a) attrlist
 in
  CurryProg
   (controllerModuleName ename)
   -- imports:
   [ timeModule
   , "HTML.Base", "HTML.Session", "HTML.WUI"
   , model erdname
   , "Config.EntityRoutes", "Config.UserProcesses"
   , sessionInfoModule, authorizationModule, enauthModName, spiceyModule
   , "System.PreludeHelpers"
   , entitiesToHtmlModule erdname
   , viewModuleName ename
   ]
   Nothing -- defaultdecl
   [] -- classdecls
   [] -- instdecls
   [newEntityType erdname entity relationships allEntities] -- typedecls
   -- functions
   (
    [
     -- controller for dispatching to various controllers:
     mainController erdname entity relationships allEntities,
     -- controller for providing a page to enter new entity data:
     --newController erdname entity relationships allEntities,
     newController erdname (Entity ename noKeyAttrs) relationships allEntities,
     newForm  erdname (Entity ename noKeyAttrs) relationships allEntities,
     newStore erdname (Entity ename noKeyAttrs) relationships allEntities,
     -- transaction for saving data in new entity:
     createTransaction erdname entity relationships allEntities,
     -- controller to show an existing record in a form to edit
     editController erdname entity relationships allEntities,
     editForm  erdname (Entity ename noKeyAttrs) relationships allEntities,
     editStore erdname (Entity ename noKeyAttrs) relationships allEntities,
     -- transaction to update a record with the given data
     updateTransaction erdname entity relationships allEntities,
     -- controller to delete an entity with the given data
     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 relationships allEntities,
     -- controller to list all entities:
     listController erdname entity relationships allEntities,
     -- controller to show entites:
     showController erdname entity relationships allEntities
    ] ++
    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


-- erdname: name of the entity-relationship-specification
-- entity: the entity to generate a controller for
type ControllerGenerator = String -> Entity -> [Relationship] -> [Entity]
                        -> CFuncDecl

-- Generates the main controller that dispatches to the various
-- subcontrollers according to the URL parameters.
mainController :: ControllerGenerator
mainController _ (Entity entityName _) _ _ =
  controllerFunction
  ("Choose the controller for a "++entityName++
   " entity according to the URL parameter.")
  entityName "main" 0
    controllerType -- function type
    [simpleRule [] -- no arguments
      (doExpr
         [CSPat (CPVar (1,"args"))
                (constF (spiceyModule,"getControllerParams")),
          CSExpr
           (CCase CRigid (CVar (1,"args"))
            ([cBranch (listPattern [])
                      (constF (controllerFunctionName entityName "list")),
              cBranch (listPattern [stringPattern "list"])
                      (constF (controllerFunctionName entityName "list")),
              cBranch (listPattern [stringPattern "new"])
                      (constF (controllerFunctionName entityName "new"))] ++
              map applyControllerBranch ["show", "edit", "delete", "destroy"] ++
             [cBranch (CPVar (3,"_"))
                      (constF (spiceyModule, "displayUrlError"))])
          )
         ]
      )]
 where
  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 _ (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 . fst) manyToManyEntities))

------------------------------------------------------------------------------
-- generates a controller to show a form to create a new entity
-- the input is then passed to the create controller
-- only has to call the blank entry form and pass the create controller
newController :: ControllerGenerator
newController erdname (Entity entityName attrList) relationships allEntities =
  controllerFunction
  ("Shows a form to create a new " ++ entityName ++ " entity.")
  entityName "new" 0
  controllerType -- function type
  [simpleRule [] $ -- no arguments
     applyF (pre "$")
       [applyF checkAuthorizationFunc
         [applyF (enauthModName, lowerFirst entityName ++ "OperationAllowed")
           [constF (authorizationModule,"NewEntity")]],
        CLambda [CPVar infovar] $
         doExpr (
          map
           (\ ((ename,erel), num) ->
              CSPat (CPVar (num,"all" ++ erel ++ ename ++ "s"))
                    (applyF (model erdname,"runQ")
                            [constF (model erdname,"queryAll" ++ ename ++ "s")])
           )
           (zip (map (\n -> (n,"")) manyToOneEntities ++ manyToManyEntities)
                [2..]) ++
         (if hasDateAttribute attrList
            then [CSPat (CPVar ctimevar) (constF (timeModule,"getClockTime"))]
            else []) ++
         (if null manyToOneEntities
            then setParCallAndReturn
            else [CSExpr $ ifThenElseExp
                    (foldr1 (\e1 e2 -> applyF (pre "||") [e1,e2])
                            (map (\ (name, varId) -> applyF (pre "null")
                                      [CVar (varId, "all" ++ name ++ "s")])
                                 (zip manyToOneEntities [2..])))
                    (applyF (pre "return")
                       [ list2ac [applyF (html "h2")
                                   [list2ac [applyF (html "htxt")
                                               [string2ac missingError]]]]])
                    (doExpr setParCallAndReturn)]
         ))]]
 where
  manyToManyEntities = manyToMany allEntities (Entity entityName attrList)
  manyToOneEntities  = manyToOne (Entity entityName attrList) relationships
  missingError = "Some related entities are required but not yet undefined"
  infovar      = (0,"sinfo")
  ctimevar     = (1,"ctime")

  setParCall =
    applyF (wuiModule "setParWuiStore")
      [constF (controllerStoreName entityName "new"),
       tupleExpr
        ([CVar infovar] ++
         map (\ ((ename,erel), i) -> CVar (i, "all" ++ erel ++ ename ++ "s"))
             (zip (map (\n -> (n,"")) manyToOneEntities ++ manyToManyEntities)
                  [2 ..])),
       tupleExpr $
         attrDefaultValues (CVar ctimevar) attrList ++
         map (\ (name, varId) -> applyF (pre "head")
                                        [CVar (varId, "all" ++ name ++ "s")])
             (zip manyToOneEntities [2..]) ++
         map (\_ -> list2ac [])
             (zip manyToManyEntities [2..])
      ]

  setParCallAndReturn =
     [CSExpr setParCall,
      CSExpr $ applyF (pre "return")
                 [list2ac [applyF (html "formElem")
                          [constF (controllerFormName entityName "new")]]]]

--- Generates the form definition to create a new entity.
newForm :: String -> Entity -> [Relationship] -> [Entity] -> CFuncDecl
newForm erdname entity@(Entity entityName attrlist) relationships allEntities =
  cmtfunc ("A WUI form to create a new " ++ entityName ++ " entity.\n" ++
           "The default values for the fields are stored in '" ++
           snd (controllerStoreName entityName "new") ++ "'.")
    (controllerFormName entityName "new") 0
    Public
    (emptyClassType $ applyTC (htmlModule "HtmlFormDef")
        [newTupleType entity relationships allEntities])
    [simpleRule []
      (applyF (wuiModule "pwui2FormDef")
        [string2ac $ showQName $ controllerFormName entityName "new",
         constF (controllerStoreName entityName "new"),
         wuiFun, storeFun, renderFun])]
 where
  manyToManyEntities = map (\ (ent,rel) -> rel ++ ent)
                           (manyToMany allEntities
                                       (Entity entityName attrlist))
  manyToOneEntities  = manyToOne (Entity entityName attrlist) relationships
  arity1 = 1 + length manyToOneEntities + length manyToManyEntities
  listEntityURL = '?' : entityName ++ "/list"

  wuiFun =
    CLambda
      [tuplePattern
        ([CPVar (1,"_")] ++
         map (\ (name, varId) -> CPVar(varId,("possible"++name++"s")))
             (zip (manyToOneEntities++manyToManyEntities) [2..]))] $
      applyF (viewModuleName entityName, "w" ++ entityName)
        (map (\ (name, varId) -> CVar(varId,("possible"++name++"s")))
             (zip (manyToOneEntities ++ manyToManyEntities) [2..]) )

  storeFun =
    let entvar    = (1, "entity")
        newentvar = (2, "newentity")
    in
    CLambda [CPVar (0,"_"), CPVar entvar]
      (applyF checkAuthorizationFunc
         [applyF (enauthModName, lowerFirst entityName ++ "OperationAllowed")
            [constF (authorizationModule,"NewEntity")],
          CLambda [CPVar (0,"_")]
            (applyF (spiceyModule,"transactionController")
               [applyF (model erdname,"runT")
                  [applyF (transFunctionName entityName "create")
                           [CVar entvar]],
                CLambda [CPVar newentvar]
                  (doExpr
                     [CSExpr $ applyF (spiceyModule,"setPageMessage")
                                [string2ac $ "New " ++ entityName ++ " created"],
                      CSExpr $ applyF (spiceyModule,"nextInProcessOr")
                        [applyF (spiceyModule,"redirectController")
                           [applyF (spiceyModule,"showRoute") [CVar newentvar]],
                         constF (pre "Nothing")]])])])

  renderFun =
    CLambda [tuplePattern
               (map CPVar (sinfovar : map (\v -> (v,"_")) [2 .. arity1]))] $
      letExpr
        [CLocalPat
           (CPVar entvar)
           (simpleRhs (simpleTyped (constF (pre "failed"))
                                   (baseType (model erdname, entityName))))]
        (applyF (spiceyModule,"renderWUI")
          [CVar sinfovar,
           string2ac $ "Create new " ++ entityName,
           string2ac "Create",
           applyF (spiceyModule,"listRoute") [CVar entvar],
           constF (pre "()")
          ])
   where sinfovar = (1, "sinfo")
         entvar   = (2, "phantom")


--- Generates the store for WUI to create a new entity.
newStore :: String -> Entity -> [Relationship] -> [Entity] -> CFuncDecl
newStore _ entity@(Entity entityName _) relationships allEntities =
  cmtfunc "The data stored for executing the \"new entity\" WUI form."
    (controllerStoreName entityName "new") 0
    Private
    (emptyClassType $
       applyTC (sessionModule "SessionStore")
         [newTupleType entity relationships allEntities])
    [simpleRule []
      (applyF (sessionModule "sessionStore")
              [string2ac $ "new" ++ entityName ++ "Store"])]


--- Computes the tuple type of the data to be stored and manipulated
--- by the WUI to create a new entity.
newTupleType :: Entity -> [Relationship] -> [Entity] -> CTypeExpr
newTupleType (Entity entityName attrlist) relationships allEntities =
  tupleType
    [tupleType $
       [userSessionInfoType] ++
       map (listType . ctvar)
           (manyToOneEntities ++ map fst manyToManyEntities), -- possible values
     applyTC (wuiModule "WuiStore")
             [baseType (newEntityTypeName entityName)]]
 where
  manyToManyEntities = manyToMany allEntities (Entity entityName attrlist)
  manyToOneEntities  = manyToOne (Entity entityName attrlist) relationships


--- Generates a transaction to store a new entity.
createTransaction :: ControllerGenerator
createTransaction erdname (Entity entityName attrList)
                  relationships allEntities = stCmtFunc
  ("Transaction to persist a new " ++ entityName ++ " entity to the database.")
  (transFunctionName entityName "create")
  1 Private
    (baseType (newEntityTypeName entityName)
      ~> applyTC (dbconn "DBAction") [baseType (model erdname,entityName)])
  [simpleRule
    [tuplePattern
      (map (\ (param, varId) -> CPVar (varId, param))
           (zip (parameterList ++ map lowerFirst manyToOneEntities ++
                 map (\ (e,r) -> lowerFirst r ++ e ++ "s") manyToManyEntities)
                 [1..]))
    ] -- parameter list for controller
    (doExpr $
       CSPat (cpvar "newentity")
         (applyF (entityConstructorFunction erdname
                    (Entity entityName attrList) relationships)
                 (map (\ ((Attribute name dom key null), varId) ->
                     if (isForeignKey (Attribute name dom key null))
                       then applyF (model erdname,
                              lowerFirst (getReferencedEntityName dom) ++ "Key")
                                   [CVar (varId,
                                       lowerFirst (getReferencedEntityName dom))]
                       else let cv = CVar (varId, lowerFirst name)
                            in if hasDefault dom && not (isStringDom dom)
                                  && not null
                                 then applyF (pre "Just") [cv]
                                 else cv)
                     (zip noPKeys [1..])
                  )) :
       map (\ (en,rel) -> CSExpr $
                          applyF (controllerModuleName entityName, "add" ++ rel)
                                 [cvar (lowerFirst rel ++ en ++ "s"),
                                  cvar "newentity"])
           manyToManyEntities ++
       [CSExpr $ applyF (pre "return") [cvar "newentity"]])
  ]
 where
  noPKeys            = (filter notPKey attrList)
  -- foreignKeys = (filter isForeignKey attrList)
  -- notGeneratedAttributes = filter (\attr -> (not (isForeignKey attr))
  --                                          && (notPKey attr))     attrList
  parameterList      = map (\(Attribute name _ _ _) -> lowerFirst name)
                           (filter (not . isForeignKey) noPKeys)
  manyToManyEntities = manyToMany allEntities (Entity entityName attrList)
  manyToOneEntities  = manyToOne (Entity entityName attrList) relationships

------------------------------------------------------------------------------
--- Generates a controller to edit an entity.
editController :: ControllerGenerator
editController erdname (Entity entityName attrList) relationships allEntities =
  controllerFunction
    ("Shows a form to edit the given " ++ entityName ++ " entity.")
    entityName "edit" 1
    (baseType (model erdname,entityName) ~> controllerType)
    [simpleRule [CPVar pvar] -- parameterlist for controller
      (applyF (pre "$")
        [applyF checkAuthorizationFunc
          [applyF (enauthModName,lowerFirst entityName ++ "OperationAllowed")
            [applyF (authorizationModule,"UpdateEntity") [CVar pvar]]],
         CLambda [CPVar infovar] $
           doExpr (
            map (\ ((ename,erel), num) ->
                  CSPat (CPVar (num,"all" ++ erel ++ ename ++ "s"))
                        (applyF (model erdname,"runQ")
                           [constF (model erdname,"queryAll" ++ ename ++ "s")]))
               (zip (map (\n -> (n,"")) manyToOneEntities ++ manyToManyEntities)
                    [1..]) ++
            map
              (\ (ename, num) -> CSPat (CPVar (num,(lowerFirst (fst $ relationshipName entityName ename relationships))++ename))
                              (
                                applyF (model erdname,"runJustT") [
                                  applyF (controllerModuleName entityName,"get"++(fst $ relationshipName entityName ename relationships)++ename) [CVar pvar]
                                ]
                              )
              )
              (zip manyToOneEntities [1..]) ++
            map
              (\ ((ename,erel), num) ->
                   CSPat (CPVar (num, lowerFirst erel ++ ename ++ "s"))
                         (applyF (model erdname,"runJustT")
                           [applyF (controllerModuleName entityName,
                                    "get" ++ erel ++ entityName ++ ename ++ "s")
                                   [CVar pvar]])
              )
              (zip manyToManyEntities [1..]) ++
            [CSExpr setParCall,
             CSExpr $ applyF (pre "return")
               [list2ac [applyF (html "formElem")
                           [constF (controllerFormName entityName "edit")]]]
            ])])]
 where
  manyToManyEntities = manyToMany allEntities (Entity entityName attrList)
  manyToOneEntities  = manyToOne (Entity entityName attrList) relationships
  pvar               = (0, lowerFirst entityName ++ "ToEdit")
  infovar            = (1, "sinfo")

  setParCall =
    applyF (wuiModule "setParWuiStore")
      [constF (controllerStoreName entityName "edit"),
       tupleExpr
        ([CVar infovar, CVar pvar] ++
         map (\ (ename, num) ->
               CVar (num,lowerFirst (fst $ relationshipName
                            entityName ename relationships)
                         ++ ename))
             (zip manyToOneEntities [1..]) ++
         map (\ ((ename,erel), num) -> CVar (num, "all" ++ erel ++ ename ++ "s"))
             (zip (map (\n -> (n,"")) manyToOneEntities ++ manyToManyEntities)
                  [1..])),
       tupleExpr
        ([CVar pvar] ++
          (map (\ ((ename,erel), num) ->
                 CVar (num,lowerFirst erel ++ ename ++ "s"))
               (zip manyToManyEntities [1..])))]


--- Generates the form definition to edit an entity.
editForm :: String -> Entity -> [Relationship] -> [Entity] -> CFuncDecl
editForm erdname entity@(Entity entityName attrlist) relationships allEntities =
  cmtfunc ("A WUI form to edit a " ++ entityName ++ " entity.\n" ++
           "The default values for the fields are stored in '" ++
           snd (controllerStoreName entityName "edit") ++ "'.")
    (controllerFormName entityName "edit") 0
    Public
    (emptyClassType $ applyTC (htmlModule "HtmlFormDef")
      [editTupleType erdname entity relationships allEntities])
    [simpleRule []
      (applyF (wuiModule "pwui2FormDef")
        [string2ac $ showQName $ controllerFormName entityName "edit",
         constF (controllerStoreName entityName "edit"),
         wuiFun, storeFun, renderFun])]
 where
  manyToManyEntities = manyToMany allEntities (Entity entityName attrlist)
  manyToOneEntities  = manyToOne (Entity entityName attrlist) relationships
  arity1 = 2 + length manyToOneEntities * 2 + length manyToManyEntities

  wuiFun =
    let relatedVars  vart = map (\ (name, varId) ->
                                     vart (varId, "related" ++ name))
                                (zip manyToOneEntities [2..])
        possibleVars vart =
          map (\ ((ename,erel), varId) ->
                             vart (varId, "possible" ++ erel ++ ename ++ "s"))
              (zip (map (\n -> (n,"")) manyToOneEntities ++ manyToManyEntities)
                   [2..])
    in CLambda
         [tuplePattern
           ([CPVar (1,"_"), CPVar (1, lowerFirst entityName)] ++
            relatedVars CPVar ++ possibleVars CPVar)] $
         applyF (viewModuleName entityName, "w" ++ entityName ++ "Type")
           ([cvar (lowerFirst entityName)] ++
             relatedVars CVar ++ possibleVars CVar)

  storeFun =
    let evar   = (1, lowerFirst entityName ++ "ToEdit")
        entvar = (2, "entity")
    in
    CLambda [CPVar (0,"_"),
             CPAs entvar
               (tuplePattern
                  ([CPVar evar] ++
                   map (\i -> CPVar (i+2,"_"))
                       [1 .. length manyToManyEntities]))]
      (applyF checkAuthorizationFunc
         [applyF (enauthModName,lowerFirst entityName ++ "OperationAllowed")
            [applyF (authorizationModule,"UpdateEntity") [CVar evar]],
          CLambda [CPVar (0,"_")]
            (applyF (spiceyModule,"transactionController")
               [applyF (model erdname,"runT")
                  [applyF (transFunctionName entityName "update")
                           [CVar entvar]],
                applyF (pre "const")
                  [doExpr
                     [CSExpr $ applyF (spiceyModule,"setPageMessage")
                                      [string2ac $ entityName ++ " updated"],
                      CSExpr $ applyF (spiceyModule,"nextInProcessOr")
                        [applyF (spiceyModule,"redirectController")
                           [applyF (spiceyModule,"showRoute") [CVar evar]],
                         constF (pre "Nothing")]]]])])

  renderFun =
    CLambda [tuplePattern
               (map CPVar (sinfovar : entvar :
                           map (\v -> (v,"_")) [3 .. arity1]))] $
      applyF (spiceyModule,"renderWUI")
        [CVar sinfovar,
         string2ac $ "Edit " ++ entityName,
         string2ac "Change",
         applyF (spiceyModule,"listRoute") [CVar entvar],
         constF (pre "()")
        ]
   where sinfovar = (1, "sinfo")
         entvar   = (2, "entity")


--- Generates the store for WUI to edit an entity.
editStore :: String -> Entity -> [Relationship] -> [Entity] -> CFuncDecl
editStore erdname entity@(Entity entityName _) relationships allEntities =
  cmtfunc "The data stored for executing the edit WUI form."
    (controllerStoreName entityName "edit") 0
    Private
    (emptyClassType $
       applyTC (sessionModule "SessionStore")
         [editTupleType erdname entity relationships allEntities])
    [simpleRule []
      (applyF (sessionModule "sessionStore")
              [string2ac $ "edit" ++ entityName ++ "Store"])]

--- Computes the tuple type of the data to be stored and manipulated
--- by the WUI to edit a new entity.
editTupleType :: String -> Entity -> [Relationship] -> [Entity] -> CTypeExpr
editTupleType erdname (Entity entityName attrlist) relationships allEntities =
  tupleType
    [tupleType $
      [userSessionInfoType, baseType (model erdname, entityName)] ++
      map ctvar manyToOneEntities ++ -- defaults for n:1
      map (listType . ctvar)
          (manyToOneEntities ++ map fst manyToManyEntities), -- possible values
     applyTC (wuiModule "WuiStore")
      [tupleType $
         [baseType (model erdname, entityName)] ++
         map (listType . ctvar . fst) manyToManyEntities]]
 where
  manyToManyEntities = manyToMany allEntities (Entity entityName attrlist)
  manyToOneEntities  = manyToOne (Entity entityName attrlist) relationships

--- Generates the transaction to update an entity.
updateTransaction :: ControllerGenerator
updateTransaction erdname (Entity entityName attrList) _ allEntities =
  stCmtFunc
    ("Transaction to persist modifications of a given " ++ entityName ++
     " entity\nto the database.")
    (transFunctionName entityName "update")
    2 Private
    (tupleType ([baseType (model erdname, entityName)] ++
                 map (\ (name,_) -> listType (ctvar name)) manyToManyEntities)
      ~> applyTC (dbconn "DBAction") [unitType])
    [simpleRule
      [tuplePattern
             ([CPVar (0, lowerFirst entityName)] ++
              (map (\ (param, varId) -> CPVar (varId, param))
                   (zip (map (\ (ename,erel) -> lowerFirst erel ++ ename ++ "s")
                             manyToManyEntities)
                        [1..])))
      ] -- parameter list for controller
      (doExpr $
         (CSExpr (applyF (model erdname, "update" ++ entityName)
                         [cvar (lowerFirst entityName)]) :
         (concatMap (\ (ename,erel) ->
            [CSPat (CPVar (0, "old" ++ erel ++ ename ++ "s"))
                   (applyF (controllerModuleName entityName,
                            "get" ++ erel ++ entityName ++ ename ++ "s")
                           [cvar (lowerFirst entityName)]),
             CSExpr (applyF (controllerModuleName entityName,
                             "remove" ++ erel)
                            [cvar ("old"++ erel ++ ename ++ "s"),
                             cvar (lowerFirst entityName)])])
               manyToManyEntities
                      ) ++
         (map (\ (ename,erel) -> CSExpr $
                  applyF (controllerModuleName entityName, "add" ++ erel)
                         [cvar (lowerFirst erel ++ ename ++ "s"),
                          cvar (lowerFirst entityName)])
              manyToManyEntities)
         ))]
 where
  manyToManyEntities = manyToMany allEntities (Entity entityName attrList)
  -- manyToOneEntities = manyToOne (Entity entityName attrList) relationships
  -- noPKeys = (filter notPKey attrList)

------------------------------------------------------------------------------
--- 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
      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 (model 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
      listEntityURL = '?' : entityName ++ "/list"
  in
  controllerFunction
  ("Deletes a given " ++ entityName ++ " entity\n" ++
   "and proceeds with the list controller.")
  entityName "destroy" 1
  (baseType (model erdname, entityName) ~> controllerType)
  [simpleRule [CPVar entvar]
    (applyF (pre "$")
       [applyF checkAuthorizationFunc
         [applyF (enauthModName,entlc++"OperationAllowed")
                 [applyF (authorizationModule,"DeleteEntity") [CVar entvar]]],
        CLambda [CPVar (0,"_")] $
         applyF (spiceyModule,"transactionController")
            [applyF (model erdname,"runT")
                    [applyF (transFunctionName entityName "delete")
                            [CVar entvar]],
             applyF (pre "const")
               [doExpr
                  [CSExpr $ applyF (spiceyModule,"setPageMessage")
                                   [string2ac $ entityName ++ " deleted"],
                   CSExpr $ applyF (spiceyModule,"redirectController")
                                   [applyF (spiceyModule,"listRoute")
                                           [CVar entvar]]]]]])]

--- Generates a transaction to delete an entity.
deleteTransaction :: ControllerGenerator
deleteTransaction erdname (Entity entityName attrs) _ allEntities =
  let manyToManyEntities = manyToMany allEntities (Entity entityName attrs)
      entlc  = lowerFirst entityName  -- entity name in lowercase
      entvar = (0, entlc)             -- entity parameter for trans.
  in
   stCmtFunc
    ("Transaction to delete a given " ++ entityName ++ " entity.")
    (transFunctionName entityName "delete")
    1 Private
    (baseType (model erdname, entityName)
      ~> applyTC (dbconn "DBAction") [unitType])
    [simpleRule
      [CPVar entvar] -- entity parameter for controller
      (doExpr $
         concatMap (\ (ename,erel) ->
           [CSPat (CPVar(0, "old" ++ erel ++ ename ++ "s"))
                  (applyF (controllerModuleName entityName,
                           "get" ++ erel ++ entityName ++ ename ++ "s")
                          [CVar entvar]),
            CSExpr (applyF (controllerModuleName entityName, "remove" ++ erel)
                           [cvar ("old" ++ erel ++ ename ++ "s"),
                            CVar entvar ])]
           )
           manyToManyEntities ++
         [CSExpr $ applyF (model erdname, "delete" ++ entityName)
                          [CVar entvar]])]

------------------------------------------------------------------------------
listController :: ControllerGenerator
listController erdname (Entity entityName _) _ _ =
  controllerFunction
    ("Lists all " ++ entityName ++ " entities with buttons to show, delete,\n"++
     "or edit an entity.")
    entityName "list" 0
    controllerType
    [simpleRule [] -- no arguments
      (applyF (pre "$")
          [applyF checkAuthorizationFunc
            [applyF (enauthModName,lowerFirst entityName ++ "OperationAllowed")
              [applyF (authorizationModule,"ListEntities") []]],
           CLambda [CPVar infovar] $ doExpr
            [CSPat (CPVar entsvar)
                   (applyF (model erdname,"runQ")
                      [constF (model erdname,"queryAll" ++ entityName ++ "s")]),
             CSExpr (applyF (pre "return")
                           [applyF (viewFunctionName entityName "list")
                                   [CVar infovar, CVar entsvar]])
            ]
         ]
        )]
 where
  infovar = (0, "sinfo")
  entsvar = (1, lowerFirst entityName ++ "s")

------------------------------------------------------------------------------
showController :: ControllerGenerator
showController erdname (Entity entityName attrs) relationships allEntities =
  let manyToManyEntities = manyToMany allEntities (Entity entityName attrs)
      manyToOneEntities  = manyToOne (Entity entityName attrs) relationships
      pvar               = (0, lowerFirst entityName)
      infovar            = (1, "sinfo")
  in
    controllerFunction
    ("Shows a " ++ entityName ++ " entity.")
    entityName "show" 1
      (baseType (model erdname,entityName) ~> controllerType)
      [simpleRule
        [CPVar pvar] -- parameterlist for controller
        (applyF (pre "$")
            [applyF checkAuthorizationFunc
              [applyF (enauthModName,lowerFirst entityName ++ "OperationAllowed")
                [applyF (authorizationModule,"ShowEntity") [CVar pvar]]],
             CLambda [CPVar infovar] $ doExpr (
               map (\ (ename, num) ->
                     CSPat (CPVar (num,lowerFirst
                                         (fst $ relationshipName entityName
                                               ename relationships) ++ ename))
                           (applyF (model erdname,"runJustT")
                              [applyF (controllerModuleName entityName,
                                       "get"++ fst (relationshipName
                                                entityName ename relationships)
                                            ++ ename)
                                      [CVar pvar]
                              ])
                   )
                   (zip (manyToOneEntities) [1..]) ++
               map (\ ((ename,erel), num) ->
                      CSPat (CPVar (num,lowerFirst erel ++ ename ++ "s"))
                            (applyF (model erdname,"runJustT")
                               [applyF (controllerModuleName entityName,
                                   "get" ++ erel ++ entityName ++ ename ++ "s")
                                       [CVar pvar]])
                   )
                   (zip manyToManyEntities [1..]) ++
              [CSExpr (
                 applyF (pre "return")
                    [applyF (viewFunctionName entityName "show")
                       ([CVar infovar, CVar pvar] ++
                        (map (\ (ename, num) ->
                                CVar (num,lowerFirst (fst $ relationshipName
                                             entityName ename relationships)
                                           ++ ename))
                             (zip (manyToOneEntities) [1..])) ++
                         (map (\ ((ename,erel), num) ->
                               CVar (num,lowerFirst erel ++ ename ++ "s"))
                             (zip manyToManyEntities [1..])))
                    ])
              ])
            ]
          )
      ]

manyToManyAddOrRemove :: String -> Entity -> [(String,String)] -> [Entity]
                      -> [CFuncDecl]
manyToManyAddOrRemove erdname (Entity entityName _) entityrels allEntities =
  map (addOrRemoveFunction "add"    "new"    entityName) entityrels ++
  map (addOrRemoveFunction "remove" "delete" entityName) entityrels
 where
  addOrRemoveFunction :: String -> String -> String -> (String,String)
                      -> CFuncDecl
  addOrRemoveFunction funcPrefix dbFuncPrefix e1 (e2,mmrel) =
    stCmtFunc
    ((if funcPrefix == "add"
        then "Associates given entities with the " ++ entityName ++ " entity"
        else "Removes association to the given entities with the " ++
             entityName ++ " entity") ++
     "\nwith respect to the `" ++ mmrel ++ "` relation.")
    (controllerModuleName e1, funcPrefix ++ mmrel)
    2
    Private
    (listType (ctvar e2) ~> ctvar e1 ~> applyTC (dbconn "DBAction")
                                               [tupleType []])
    [simpleRule [CPVar (0, lowerFirst e2 ++ "s"),
                 CPVar (1, lowerFirst e1)]
      (applyF (pre "mapM_")
         [CLambda [CPVar(2, "t")]
           (applyF (model erdname, dbFuncPrefix ++ mmrel)
             [applyF (model erdname, lowerFirst e1 ++ "Key")
                     [cvar (lowerFirst e1)],
              applyF (model erdname, lowerFirst e2 ++ "Key") [cvar "t"]]),
          cvar (lowerFirst e2 ++ "s")])]

getAll :: String -> Entity -> [String] -> [Entity] -> [CFuncDecl]
getAll erdname (Entity entityName _) entities _ =
    map getAllFunction entities
  where
    getAllFunction :: String -> CFuncDecl
    getAllFunction foreignEntity =
      stCmtFunc
      ("Gets all " ++ foreignEntity ++ " entities.")
      (controllerModuleName entityName, "getAll" ++ foreignEntity ++ "s")
      0
      Private
      (ioType (listType (ctvar foreignEntity)))
      [simpleRule []
        (applyF (model erdname,"runQ")
          [applyF (model erdname,"queryAll")
            [CLambda [CPVar(0, take 1 (lowerFirst foreignEntity) )]
                     (CLetDecl [(CLocalVars [(1,"key")])]
                        (applyF (model erdname, lowerFirst foreignEntity)
                                [cvar "key",
                                 cvar (take 1 (lowerFirst foreignEntity))]))
                    ]
            ]
       )
      ]


manyToOneGetRelated :: String -> Entity -> [String] -> [Entity]
                    -> [Relationship] -> [CFuncDecl]
manyToOneGetRelated erdname (Entity entityName _) entities _ relationships =
    map getRelatedFunction entities
  where
    getRelatedFunction :: String -> CFuncDecl
    getRelatedFunction foreignEntity =
      let argvar  = (1, (take 1 $ lowerFirst entityName) ++ foreignEntity)
          rname   = fst (relationshipName entityName foreignEntity relationships)
          fkeysel = lowerFirst entityName ++ foreignEntity ++ rname ++ "Key"
      in
      stCmtFunc
      ("Gets the associated " ++ foreignEntity ++ " entity for a given "++
       entityName ++ " entity.")
      (controllerModuleName entityName,
       "get" ++ rname ++ foreignEntity)
      0
      Private
      ((ctvar entityName) ~> applyTC (dbconn "DBAction") [ctvar foreignEntity])
      [simpleRule [CPVar argvar]
                  (applyF (model erdname,"get" ++ foreignEntity)
                          [applyF (model erdname,fkeysel) [CVar argvar]])]

relationshipName :: String -> String -> [Relationship] -> (String, String)
relationshipName e1 e2 (rel:relrest)=
  case rel of
    (Relationship name [(REnd relE1 _ _), (REnd relE2 relName _)]) ->
      if ((relE1 == e1 && relE2 == e2) || (relE1 == e2 && relE2 == e1))
        then (name, relName)
        else relationshipName e1 e2 relrest
relationshipName _ _ [] = error "relationshipName: relationship not found"

---- auxiliaries ---

displayErrorFunction :: QName
displayErrorFunction = (spiceyModule, "displayError")

entityConstructorFunction :: String -> Entity -> [Relationship] -> QName
entityConstructorFunction erdname (Entity entityName attrs) relationships =
  (model erdname,
   "new" ++ entityName ++ newSuffix entityName attrs relationships)

-- entityName: Name of entity the controller should be generated for
-- controllerType: the function of the generated Controller, e.g. "new", "edit", "list"
-- arity
-- functionType: the type of the controller function
-- rules: the rules defining the controller
controllerFunction :: String -> String -> String -> Int -> CTypeExpr -> [CRule]
                   -> CFuncDecl
controllerFunction description entityName controllerType arity functionType
                   rules =
  stCmtFunc description
            (controllerFunctionName entityName controllerType)
            arity
            (if controllerType `elem` ["main"]
               then Public
               else Private)
            functionType rules

getReferencedEntityName :: Domain -> String
getReferencedEntityName t =
  case t of KeyDom kd -> kd
            _         -> ""

relatedEntityNames :: Entity -> [Relationship] -> [String]
relatedEntityNames (Entity entityName attrlist) relationships =
  map (\ (Relationship _ ((REnd name1 _ _) : (REnd name2 _ _) : [])) ->
            if name1 == entityName then name2 else name1)
      (relationshipsForEntity (Entity entityName attrlist) relationships)

-- gets all relationships 
relationshipsForEntity :: Entity -> [Relationship] -> [Relationship]
relationshipsForEntity (Entity entityName _) relationships =
  filter (\ (Relationship _ ((REnd name1 _ _) : (REnd name2 _ _):[])) ->
             name1 == entityName || name2 == entityName)
         (filter (not . isGeneratedR) relationships)

------ from ERD CodeGeneration

newSuffix :: String -> [Attribute] -> [Relationship] -> String
newSuffix eName attrs rels =
  let
    generatedRs = filter isGeneratedR rels
    exactRs  = filter isExactB  generatedRs --(i,i), i>1
    maxRs    = filter isMaxB    generatedRs --(0,i), i>1
    minMaxRs = filter isMinMaxB generatedRs --(i,j), i>0, j>i
  in
    concatMap ("With"++)
              (map attributeName (filter isForeignKey attrs)) ++
    if (length (exactRs ++ maxRs ++ minMaxRs))==0
    then ""
    else concatMap (\k->"With" ++ k ++ "Keys")
                   (map (relatedRelation eName)
                        (exactRs ++ maxRs ++ minMaxRs))
  where
    isExactB (Relationship _ [REnd _ _ _, REnd _ _ c]) =
      case c of Exactly i -> i>1
                _         -> False
    isMaxB (Relationship _ [REnd _ _ _, REnd _ _ c]) =
      case c of (Between 0 (Max i)) -> i>1
                _                   -> False
    isMinMaxB (Relationship _ [REnd _ _ _, REnd _ _ c]) =
      case c of (Between i (Max j)) -> i>0 && j>i
                _                   -> False

isGeneratedR :: Relationship -> Bool
isGeneratedR (Relationship n _) = n == ""

-- extracts the name of the relationship related to a given entity name
relatedRelation :: String -> Relationship -> String
relatedRelation en (Relationship _ [REnd en1 _ _, REnd en2 _ _]) =
  if en==en1 then en2 else en1

relationshipsForEntityName :: String -> [Relationship] -> [Relationship]
relationshipsForEntityName ename rels = filter endsIn rels
 where
  endsIn (Relationship _ ends) = any (\ (REnd n _ _) -> ename == n) ends

------------------------------------------------------------------------
-- Auxiliaries:

getUserSessionInfoFunc :: CExpr
getUserSessionInfoFunc = constF (sessionInfoModule,"getUserSessionInfo")

checkAuthorizationFunc :: QName
checkAuthorizationFunc = (authorizationModule,"checkAuthorization")

------------------------------------------------------------------------