Removed ModelControllerMap

IHP/IDE/CodeGen/ControllerGenerator.hs

@@ -47,8 +47,7 @@ data ControllerConfig = ControllerConfig
 
 controllerInstance :: ControllerConfig -> Text
 controllerInstance ControllerConfig { controllerName, modelName, applicationName } =
-    "instance AutoRoute " <> controllerName <> "Controller\n"
-    <> "type instance ModelControllerMap " <> applicationName <> "Application " <> modelName <> " = " <> controllerName <> "Controller\n\n"
+    "instance AutoRoute " <> controllerName <> "Controller\n\n"
 
 data HaskellModule = HaskellModule { moduleName :: Text, body :: Text }
 

IHP/RouterSupport.hs

@@ -9,7 +9,6 @@ CanRoute (..)
 , startPage
 , frontControllerToWAIApp
 , withPrefix
-, ModelControllerMap
 , FrontController (..)
 , parseRoute 
 , catchAll
@@ -93,10 +92,6 @@ class HasPath controller => CanRoute controller where
     parseRoute' :: (?applicationContext :: ApplicationContext, ?context :: RequestContext) => Parser controller
 
 
--- | Maps models to their restful controllers
--- E.g. ModelControllerMap ControllerContext User = UsersController
-type family ModelControllerMap controllerContext model
-
 class Data controller => AutoRoute controller where
     {-# INLINE autoRoute #-}
     autoRoute :: (?applicationContext :: ApplicationContext, ?context :: RequestContext) => Parser controller

IHP/View/Form.hs

@@ -35,32 +35,53 @@ import IHP.HtmlSupport.QQ (hsx)
 import IHP.View.Types
 import IHP.View.Classes 
 import IHP.FrameworkConfig (ConfigProvider)
+import qualified Network.Wai as Wai
+import IHP.Controller.RequestContext
 
+class ModelFormAction application record where
+    modelFormAction :: (?context :: context, HasField "requestContext" context RequestContext) => record -> Text
+
+-- | Returns the form's action attribute for a given record.
+--
+-- Expects that AutoRoute is used. Otherwise you need to use @formFor'@ or specify
+-- a manual ModelFormAction instance.
+--
+-- We guess the form submitt action based on the current url
+-- It's a @New..Action@ or @Edit..Action@. We guess the corresponding
+-- @Create..Action@ name or @Update..Action@ name based on the AutoRoute rules
+--
+-- In case the routing is not based on AutoRoute, a manual ModelFormAction instance needs
+-- to be defined
 instance (
     HasField "id" record id
-    , controller ~ ModelControllerMap application (NormalizeModel record)
-    , HasPath controller
-    , AutoRoute controller
     , Eq id
     , Default id
+    , KnownSymbol (GetModelName record)
     ) => ModelFormAction application record where
-    modelFormAction record = let id = getField @"id" record in if id == def
-        then pathTo (fromJust (createAction @controller))
-        else pathTo (fromJust (updateAction @controller) id)
-    {-# INLINE modelFormAction #-}
+    modelFormAction record =
+        let
+            path = theRequest |> get #pathInfo
+            action = if isNew record
+                then "Create" <> getModelName @record
+                else "Update" <> getModelName @record
+        in
+            init path
+                |> (\path -> path <> [action])
+                |> intercalate "/"
+
 
 formFor :: forall record viewContext parent id application. (
     ?context :: viewContext
     , Eq record
     , Typeable record
     , ModelFormAction application record
     , HasField "id" record id
-    , HasPath (ModelControllerMap application (NormalizeModel record))
     , application ~ ViewApp viewContext
     , HasField "meta" record MetaBag
     , Default id
     , Eq id
     , ConfigProvider viewContext
+    , HasField "requestContext" viewContext RequestContext
     ) => record -> ((?context :: viewContext, ?formContext :: FormContext record) => Html5.Html) -> Html5.Html
 formFor record = buildForm (createFormContext record) { formAction = modelFormAction @application record }
 {-# INLINE formFor #-}
@@ -86,7 +107,6 @@ horizontalFormFor :: forall record viewContext parent id application. (
         , Typeable record
         , ModelFormAction application record
         , HasField "id" record id
-        , HasPath (ModelControllerMap application record)
         , application ~ ViewApp viewContext
         , HasField "meta" record MetaBag
         , Default id

IHP/View/Types.hs

@@ -10,7 +10,6 @@ module IHP.View.Types
 , SubmitButton (..)
 , FormContext (..)
 , InputType (..)
-, ModelFormAction (..)
 , CSSFramework (..)
 )
 where
@@ -19,9 +18,6 @@ import IHP.Prelude hiding (div)
 import qualified Text.Blaze.Html5 as Blaze
 import IHP.FlashMessages.Types
 
-class ModelFormAction application record where
-    modelFormAction :: record -> Text
-
 data FormField = FormField
     { fieldType :: !InputType
     , fieldName :: !Blaze.AttributeValue

Test/IDE/CodeGeneration/ControllerGenerator.hs

@@ -41,7 +41,7 @@ tests = do
 
             builtPlan `shouldBe` [
                   CreateFile {filePath = "Web/Controller/Pages.hs", fileContent = "module Web.Controller.Pages where\n\nimport Web.Controller.Prelude\nimport Web.View.Pages.Index\nimport Web.View.Pages.New\nimport Web.View.Pages.Edit\nimport Web.View.Pages.Show\n\ninstance Controller PagesController where\n    action PagesAction = do\n        pages <- query @Page |> fetch\n        render IndexView { .. }\n\n    action NewPageAction = do\n        let page = newRecord\n        render NewView { .. }\n\n    action ShowPageAction { pageId } = do\n        page <- fetch pageId\n        render ShowView { .. }\n\n    action EditPageAction { pageId } = do\n        page <- fetch pageId\n        render EditView { .. }\n\n    action UpdatePageAction { pageId } = do\n        page <- fetch pageId\n        page\n            |> buildPage\n            |> ifValid \\case\n                Left page -> render EditView { .. }\n                Right page -> do\n                    page <- page |> updateRecord\n                    setSuccessMessage \"Page updated\"\n                    redirectTo EditPageAction { .. }\n\n    action CreatePageAction = do\n        let page = newRecord @Page\n        page\n            |> buildPage\n            |> ifValid \\case\n                Left page -> render NewView { .. } \n                Right page -> do\n                    page <- page |> createRecord\n                    setSuccessMessage \"Page created\"\n                    redirectTo PagesAction\n\n    action DeletePageAction { pageId } = do\n        page <- fetch pageId\n        deleteRecord page\n        setSuccessMessage \"Page deleted\"\n        redirectTo PagesAction\n\nbuildPage page = page\n    |> fill @'[]\n"}
-                , AppendToFile {filePath = "Web/Routes.hs", fileContent = "\ninstance AutoRoute PagesController\ntype instance ModelControllerMap WebApplication Page = PagesController\n\n"}
+                , AppendToFile {filePath = "Web/Routes.hs", fileContent = "\ninstance AutoRoute PagesController\n\n"}
                 , AppendToFile {filePath = "Web/Types.hs", fileContent = "\ndata PagesController\n    = PagesAction\n    | NewPageAction\n    | ShowPageAction { pageId :: !(Id Page) }\n    | CreatePageAction\n    | EditPageAction { pageId :: !(Id Page) }\n    | UpdatePageAction { pageId :: !(Id Page) }\n    | DeletePageAction { pageId :: !(Id Page) }\n    deriving (Eq, Show, Data)\n"}
                 , AppendToMarker {marker = "-- Controller Imports", filePath = "Web/FrontController.hs", fileContent = "import Web.Controller.Pages"}
                 , AppendToMarker {marker = "-- Generator Marker", filePath = "Web/FrontController.hs", fileContent = "        , parseRoute @PagesController"}
@@ -68,7 +68,7 @@ tests = do
 
             builtPlan `shouldBe` [
                   CreateFile {filePath = "Web/Controller/Page.hs", fileContent = "module Web.Controller.Page where\n\nimport Web.Controller.Prelude\nimport Web.View.Page.Index\nimport Web.View.Page.New\nimport Web.View.Page.Edit\nimport Web.View.Page.Show\n\ninstance Controller PageController where\n    action PagesAction = do\n        page <- query @Page |> fetch\n        render IndexView { .. }\n\n    action NewPageAction = do\n        let page = newRecord\n        render NewView { .. }\n\n    action ShowPageAction { pageId } = do\n        page <- fetch pageId\n        render ShowView { .. }\n\n    action EditPageAction { pageId } = do\n        page <- fetch pageId\n        render EditView { .. }\n\n    action UpdatePageAction { pageId } = do\n        page <- fetch pageId\n        page\n            |> buildPage\n            |> ifValid \\case\n                Left page -> render EditView { .. }\n                Right page -> do\n                    page <- page |> updateRecord\n                    setSuccessMessage \"Page updated\"\n                    redirectTo EditPageAction { .. }\n\n    action CreatePageAction = do\n        let page = newRecord @Page\n        page\n            |> buildPage\n            |> ifValid \\case\n                Left page -> render NewView { .. } \n                Right page -> do\n                    page <- page |> createRecord\n                    setSuccessMessage \"Page created\"\n                    redirectTo PagesAction\n\n    action DeletePageAction { pageId } = do\n        page <- fetch pageId\n        deleteRecord page\n        setSuccessMessage \"Page deleted\"\n        redirectTo PagesAction\n\nbuildPage page = page\n    |> fill @'[]\n"}
-                , AppendToFile {filePath = "Web/Routes.hs", fileContent = "\ninstance AutoRoute PageController\ntype instance ModelControllerMap WebApplication Page = PageController\n\n"}
+                , AppendToFile {filePath = "Web/Routes.hs", fileContent = "\ninstance AutoRoute PageController\n\n"}
                 , AppendToFile {filePath = "Web/Types.hs", fileContent = "\ndata PageController\n    = PagesAction\n    | NewPageAction\n    | ShowPageAction { pageId :: !(Id Page) }\n    | CreatePageAction\n    | EditPageAction { pageId :: !(Id Page) }\n    | UpdatePageAction { pageId :: !(Id Page) }\n    | DeletePageAction { pageId :: !(Id Page) }\n    deriving (Eq, Show, Data)\n"}
                 , AppendToMarker {marker = "-- Controller Imports", filePath = "Web/FrontController.hs", fileContent = "import Web.Controller.Page"}
                 , AppendToMarker {marker = "-- Generator Marker", filePath = "Web/FrontController.hs", fileContent = "        , parseRoute @PageController"}
@@ -95,7 +95,7 @@ tests = do
 
             builtPlan `shouldBe` [
                   CreateFile {filePath = "Web/Controller/PageComment.hs", fileContent = "module Web.Controller.PageComment where\n\nimport Web.Controller.Prelude\nimport Web.View.PageComment.Index\nimport Web.View.PageComment.New\nimport Web.View.PageComment.Edit\nimport Web.View.PageComment.Show\n\ninstance Controller PageCommentController where\n    action PageCommentsAction = do\n        pageComment <- query @PageComment |> fetch\n        render IndexView { .. }\n\n    action NewPageCommentAction = do\n        let pageComment = newRecord\n        render NewView { .. }\n\n    action ShowPageCommentAction { pageCommentId } = do\n        pageComment <- fetch pageCommentId\n        render ShowView { .. }\n\n    action EditPageCommentAction { pageCommentId } = do\n        pageComment <- fetch pageCommentId\n        render EditView { .. }\n\n    action UpdatePageCommentAction { pageCommentId } = do\n        pageComment <- fetch pageCommentId\n        pageComment\n            |> buildPageComment\n            |> ifValid \\case\n                Left pageComment -> render EditView { .. }\n                Right pageComment -> do\n                    pageComment <- pageComment |> updateRecord\n                    setSuccessMessage \"PageComment updated\"\n                    redirectTo EditPageCommentAction { .. }\n\n    action CreatePageCommentAction = do\n        let pageComment = newRecord @PageComment\n        pageComment\n            |> buildPageComment\n            |> ifValid \\case\n                Left pageComment -> render NewView { .. } \n                Right pageComment -> do\n                    pageComment <- pageComment |> createRecord\n                    setSuccessMessage \"PageComment created\"\n                    redirectTo PageCommentsAction\n\n    action DeletePageCommentAction { pageCommentId } = do\n        pageComment <- fetch pageCommentId\n        deleteRecord pageComment\n        setSuccessMessage \"PageComment deleted\"\n        redirectTo PageCommentsAction\n\nbuildPageComment pageComment = pageComment\n    |> fill @'[]\n"}
-                , AppendToFile {filePath = "Web/Routes.hs", fileContent = "\ninstance AutoRoute PageCommentController\ntype instance ModelControllerMap WebApplication PageComment = PageCommentController\n\n"}
+                , AppendToFile {filePath = "Web/Routes.hs", fileContent = "\ninstance AutoRoute PageCommentController\n\n"}
                 , AppendToFile {filePath = "Web/Types.hs", fileContent = "\ndata PageCommentController\n    = PageCommentsAction\n    | NewPageCommentAction\n    | ShowPageCommentAction { pageCommentId :: !(Id PageComment) }\n    | CreatePageCommentAction\n    | EditPageCommentAction { pageCommentId :: !(Id PageComment) }\n    | UpdatePageCommentAction { pageCommentId :: !(Id PageComment) }\n    | DeletePageCommentAction { pageCommentId :: !(Id PageComment) }\n    deriving (Eq, Show, Data)\n"}
                 , AppendToMarker {marker = "-- Controller Imports", filePath = "Web/FrontController.hs", fileContent = "import Web.Controller.PageComment"}
                 , AppendToMarker {marker = "-- Generator Marker", filePath = "Web/FrontController.hs", fileContent = "        , parseRoute @PageCommentController"}
@@ -121,7 +121,7 @@ tests = do
 
             builtPlan `shouldBe` [
                   CreateFile {filePath = "Web/Controller/PageComment.hs", fileContent = "module Web.Controller.PageComment where\n\nimport Web.Controller.Prelude\nimport Web.View.PageComment.Index\nimport Web.View.PageComment.New\nimport Web.View.PageComment.Edit\nimport Web.View.PageComment.Show\n\ninstance Controller PageCommentController where\n    action PageCommentsAction = do\n        pageComment <- query @PageComment |> fetch\n        render IndexView { .. }\n\n    action NewPageCommentAction = do\n        let pageComment = newRecord\n        render NewView { .. }\n\n    action ShowPageCommentAction { pageCommentId } = do\n        pageComment <- fetch pageCommentId\n        render ShowView { .. }\n\n    action EditPageCommentAction { pageCommentId } = do\n        pageComment <- fetch pageCommentId\n        render EditView { .. }\n\n    action UpdatePageCommentAction { pageCommentId } = do\n        pageComment <- fetch pageCommentId\n        pageComment\n            |> buildPageComment\n            |> ifValid \\case\n                Left pageComment -> render EditView { .. }\n                Right pageComment -> do\n                    pageComment <- pageComment |> updateRecord\n                    setSuccessMessage \"PageComment updated\"\n                    redirectTo EditPageCommentAction { .. }\n\n    action CreatePageCommentAction = do\n        let pageComment = newRecord @PageComment\n        pageComment\n            |> buildPageComment\n            |> ifValid \\case\n                Left pageComment -> render NewView { .. } \n                Right pageComment -> do\n                    pageComment <- pageComment |> createRecord\n                    setSuccessMessage \"PageComment created\"\n                    redirectTo PageCommentsAction\n\n    action DeletePageCommentAction { pageCommentId } = do\n        pageComment <- fetch pageCommentId\n        deleteRecord pageComment\n        setSuccessMessage \"PageComment deleted\"\n        redirectTo PageCommentsAction\n\nbuildPageComment pageComment = pageComment\n    |> fill @'[]\n"}
-                , AppendToFile {filePath = "Web/Routes.hs", fileContent = "\ninstance AutoRoute PageCommentController\ntype instance ModelControllerMap WebApplication PageComment = PageCommentController\n\n"}
+                , AppendToFile {filePath = "Web/Routes.hs", fileContent = "\ninstance AutoRoute PageCommentController\n\n"}
                 , AppendToFile {filePath = "Web/Types.hs", fileContent = "\ndata PageCommentController\n    = PageCommentsAction\n    | NewPageCommentAction\n    | ShowPageCommentAction { pageCommentId :: !(Id PageComment) }\n    | CreatePageCommentAction\n    | EditPageCommentAction { pageCommentId :: !(Id PageComment) }\n    | UpdatePageCommentAction { pageCommentId :: !(Id PageComment) }\n    | DeletePageCommentAction { pageCommentId :: !(Id PageComment) }\n    deriving (Eq, Show, Data)\n"}
                 , AppendToMarker {marker = "-- Controller Imports", filePath = "Web/FrontController.hs", fileContent = "import Web.Controller.PageComment"}
                 , AppendToMarker {marker = "-- Generator Marker", filePath = "Web/FrontController.hs", fileContent = "        , parseRoute @PageCommentController"}