wrapForm created, not used everywhere yet

src/Handler/Admin.hs

@@ -55,13 +55,14 @@ emailTestForm = (,)
       SelFormatTime -> t
 
 makeDemoForm :: Int -> Form (Int,Bool,Double)
-makeDemoForm n = identifyForm "adminTestForm" $ \html -> do -- Important: used identForm instead!
+makeDemoForm n = identForm FIDAdminDemo $ \html -> do -- Important: used identForm instead!
     (result, widget) <- flip (renderAForm FormStandard) html $ (,,)
         <$> areq (minIntField n "Zahl") (fromString $ "Ganzzahl > " ++ show n) Nothing
         <*  aformSection MsgFormBehaviour
         <*> areq checkBoxField "Muss nächste Zahl größer sein?" (Just True)
         <*> areq doubleField "Fliesskommazahl" Nothing
-        <*  submitButton
+        -- NO LONGER DESIRED IN AFORMS:
+        -- <*  submitButton
     return $ case result of
       FormSuccess fsres
         | errorMsgs <- validateResult fsres
@@ -103,7 +104,6 @@ postAdminTestR = do
   let demoFormAction (_i,_b,_d) = addMessage Info "All ok."
   ((demoResult, formWidget),formEnctype) <- runFormPost $ makeDemoForm 7
   formResult demoResult demoFormAction
-  let actionUrl = AdminTestR
   let showDemoResult = [whamlet|
           $maybe (i,b,d) <- formResult' demoResult
             Received values:
@@ -133,7 +133,13 @@ postAdminTestR = do
     $(widgetFile "adminTest")
 
     [whamlet|<h2>Formular Demonstration|]
-    $(widgetFile "formPage")
+    wrapForm formWidget FormSettings
+      { formMethod   = methodPost
+      , formAction   = SomeRoute $ AdminTestR :#: FIDAdminDemo
+      , formEncoding = formEnctype
+      , formSubmit   = FormSubmit
+      , formAnchor   = Just FIDAdminDemo
+      }
     showDemoResult
 
 

src/Handler/Utils/Form.hs

@@ -45,6 +45,7 @@ import Utils.Lens
 import Data.Aeson (eitherDecodeStrict')
 import Data.Aeson.Text (encodeToLazyText)
 
+
 ----------------------------
 -- Buttons (new version ) --
 ----------------------------

src/Utils.hs

@@ -22,6 +22,7 @@ import Utils.DB as Utils
 import Utils.TH as Utils
 import Utils.DateTime as Utils
 import Utils.PathPiece as Utils
+import Utils.Route as Utils
 import Utils.Message as Utils
 import Utils.Lang as Utils
 import Control.Lens as Utils (none)
@@ -103,25 +104,6 @@ unsupportedAuthPredicate = do
     |]
 
 
-class RedirectUrl site url => HasRoute site url where
-  urlRoute :: url -> Route site
-
-instance HasRoute site (Route site) where
-  urlRoute = id
-instance (key ~ Text, val ~ Text) => HasRoute site (Route site, Map key val) where
-  urlRoute = view _1
-instance (key ~ Text, val ~ Text) => HasRoute site (Route site, [(key, val)]) where
-  urlRoute = view _1
-instance (HasRoute site a, PathPiece b) => HasRoute site (Fragment a b) where
-  urlRoute (a :#: _) = urlRoute a
-
-data SomeRoute site = forall url. HasRoute site url => SomeRoute url
-
-instance RedirectUrl site (SomeRoute site) where
-  toTextUrl (SomeRoute url) = toTextUrl url
-instance HasRoute site (SomeRoute site) where
-  urlRoute (SomeRoute url) = urlRoute url
-
 
 -- | A @Widget@ for any site; no language interpolation, etc.
 type WidgetSiteless = forall site. forall m. (MonadIO m, MonadThrow m, MonadBaseControl IO m)

src/Utils/Form.hs

@@ -29,52 +29,11 @@ import Data.UUID
 
 import Utils.Message
 import Utils.PathPiece
+import Utils.Route
 
 import Data.Proxy
 
--------------------
--- Form Renderer --
--------------------
 
--- | Use this type to pass information to the form template
-data FormLayout = FormStandard | FormDBTableFilter | FormDBTablePagesize
-
-renderAForm :: Monad m => FormLayout -> FormRender m a
-renderAForm formLayout aform fragment = do
-  (res, ($ []) -> fieldViews) <- aFormToForm aform
-  let widget = $(widgetFile "widgets/form/form")
-  return (res, widget)
-
--- | special id to identify form section headers, see 'aformSection' and 'formSection'
---   currently only treated by form generation through 'renderAForm'
-idFormSectionNoinput :: Text
-idFormSectionNoinput = "form-section-noinput"
-
--- | Generates a form having just a form-section-header and no input title.
---   Currently only correctly rendered by 'renderAForm' and mforms using 'widget/form.hamlet'
---   Usage:
---   @
---      (,) <$  formSection MsgInt
---          <*> areq intField "int here" Nothing
---          <*  formSection MsgDouble
---          <*> areq doubleField "double there " Nothing
---          <*  submitButton
---   @
---   If tooltips or other attributes are required, see 'formSection\'' instead.
-aformSection :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site msg) => msg -> AForm m ()
-aformSection = formToAForm . fmap (second pure) . formSection
-
-formSection :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site msg) => msg -> MForm m (FormResult (), FieldView site) -- TODO: WIP, delete
-formSection formSectionTitle = do
-    mr <- getMessageRender
-    return (FormSuccess (), FieldView
-      { fvLabel    = toHtml $ mr formSectionTitle
-      , fvTooltip  = Nothing
-      , fvId       = idFormSectionNoinput
-      , fvErrors   = Nothing
-      , fvRequired = False
-      , fvInput    = mempty
-      })
 
 
 --------------------
@@ -188,45 +147,7 @@ inputReadonly = addAttr "readonly" ""
 addAutosubmit :: FieldSettings site -> FieldSettings site
 addAutosubmit = addAttr "data-autosubmit" ""
 
-------------------------------------------------
--- Unique Form Identifiers to avoid accidents --
-------------------------------------------------
 
-data FormIdentifier
-  = FIDcourse
-  | FIDsheet
-  | FIDsubmission
-  | FIDsettings
-  | FIDcorrectors
-  | FIDcorrectorTable
-  | FIDcorrection
-  | FIDcorrectionsUpload
-  | FIDcorrectionUpload
-  | FIDSystemMessageAdd
-  | FIDSystemMessageTable
-  | FIDSystemMessageModify
-  | FIDSystemMessageModifyTranslation UUID
-  | FIDSystemMessageAddTranslation
-  | FIDDBTableFilter
-  | FIDDBTablePagesize
-  | FIDDelete
-  deriving (Eq, Ord, Read, Show)
-
-instance PathPiece FormIdentifier where
-  fromPathPiece = readFromPathPiece
-  toPathPiece = showToPathPiece
-
-
-identForm :: (Monad m, PathPiece ident)
-          => ident -- ^ Form identification
-          -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
-          -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
-identForm = identifyForm . toPathPiece
-
-{- Hinweise zur Erinnerung:
-  - identForm primär, wenn es mehr als ein Formular pro Handler gibt
-  - nur einmal pro makeForm reicht
--}
 
 ----------------------------
 -- Buttons (new version ) --
@@ -426,6 +347,120 @@ optionsFinite = do
       }
   return . mkOptionList $ mkOption <$> universeF
 
+
+
+------------------------------------------------
+-- Unique Form Identifiers to avoid accidents --
+------------------------------------------------
+
+data FormIdentifier
+  = FIDcourse
+  | FIDsheet
+  | FIDsubmission
+  | FIDsettings
+  | FIDcorrectors
+  | FIDcorrectorTable
+  | FIDcorrection
+  | FIDcorrectionsUpload
+  | FIDcorrectionUpload
+  | FIDSystemMessageAdd
+  | FIDSystemMessageTable
+  | FIDSystemMessageModify
+  | FIDSystemMessageModifyTranslation UUID
+  | FIDSystemMessageAddTranslation
+  | FIDDBTableFilter
+  | FIDDBTablePagesize
+  | FIDDelete
+  | FIDAdminDemo
+  deriving (Eq, Ord, Read, Show)
+
+instance PathPiece FormIdentifier where
+  fromPathPiece = readFromPathPiece
+  toPathPiece = showToPathPiece
+
+
+identForm :: (Monad m, PathPiece ident)
+          => ident -- ^ Form identification
+          -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
+          -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
+identForm = identifyForm . toPathPiece
+
+{- Hinweise zur Erinnerung:
+  - identForm primär, wenn es mehr als ein Formular pro Handler gibt
+  - nur einmal pro makeForm reicht
+-}
+
+
+
+-----------
+-- Forms --
+-----------
+
+data FormSubmitType = FormNoSubmit | FormSubmit | FormDualSubmit
+    deriving (Eq, Ord, Enum, Read, Show, Typeable, Generic)
+
+data FormSettings site = FormSettings
+      { formMethod     :: Method
+      , formAction     :: SomeRoute site
+      , formEncoding   :: Enctype
+      , formSubmit     :: FormSubmitType
+      , formAnchor     :: Maybe FormIdentifier
+      }
+
+wrapForm :: (Button site ButtonSubmit) => WidgetT site IO () -> FormSettings site -> WidgetT site IO ()
+wrapForm formWidget FormSettings{..} = do
+  formId <- maybe newIdent (return . toPathPiece) formAnchor
+  formActionUrl <- toTextUrl formAction
+  $(widgetFile "widgets/form/form")
+
+
+-------------------
+-- Form Renderer --
+-------------------
+
+-- | Use this type to pass information to the form template
+data FormLayout = FormStandard | FormDBTableFilter | FormDBTablePagesize
+
+renderAForm :: Monad m => FormLayout -> FormRender m a
+renderAForm formLayout aform fragment = do
+  (res, ($ []) -> fieldViews) <- aFormToForm aform
+  let widget = $(widgetFile "widgets/aform/aform")
+  return (res, widget)
+
+
+-- | special id to identify form section headers, see 'aformSection' and 'formSection'
+--   currently only treated by form generation through 'renderAForm'
+idFormSectionNoinput :: Text
+idFormSectionNoinput = "form-section-noinput"
+
+-- | Generates a form having just a form-section-header and no input title.
+--   Currently only correctly rendered by 'renderAForm' and mforms using 'widget/form.hamlet'
+--   Usage:
+--   @
+--      (,) <$  formSection MsgInt
+--          <*> areq intField "int here" Nothing
+--          <*  formSection MsgDouble
+--          <*> areq doubleField "double there " Nothing
+--          <*  submitButton
+--   @
+--   If tooltips or other attributes are required, see 'formSection\'' instead.
+aformSection :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site msg) => msg -> AForm m ()
+aformSection = formToAForm . fmap (second pure) . formSection
+
+formSection :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site msg) => msg -> MForm m (FormResult (), FieldView site) -- TODO: WIP, delete
+formSection formSectionTitle = do
+    mr <- getMessageRender
+    return (FormSuccess (), FieldView
+      { fvLabel    = toHtml $ mr formSectionTitle
+      , fvTooltip  = Nothing
+      , fvId       = idFormSectionNoinput
+      , fvErrors   = Nothing
+      , fvRequired = False
+      , fvInput    = mempty
+      })
+
+
+
 -------------------
 -- Special Forms --
 -------------------

src/Utils/Route.hs

@@ -0,0 +1,27 @@
+module Utils.Route where
+
+import Control.Lens
+import ClassyPrelude.Yesod -- hiding (foldlM)
+
+
+class RedirectUrl site url => HasRoute site url where
+  urlRoute :: url -> Route site
+
+instance HasRoute site (Route site) where
+  urlRoute = id
+-- | for GET-Parameters
+instance (key ~ Text, val ~ Text) => HasRoute site (Route site, Map key val) where
+  urlRoute = view _1
+-- | for GET-Parameters
+instance (key ~ Text, val ~ Text) => HasRoute site (Route site, [(key, val)]) where
+  urlRoute = view _1
+-- | for PageAnchors, implemented through Fragments
+instance (HasRoute site a, PathPiece b) => HasRoute site (Fragment a b) where
+  urlRoute (a :#: _) = urlRoute a
+
+data SomeRoute site = forall url. HasRoute site url => SomeRoute url
+
+instance RedirectUrl site (SomeRoute site) where
+  toTextUrl (SomeRoute url) = toTextUrl url
+instance HasRoute site (SomeRoute site) where
+  urlRoute (SomeRoute url) = urlRoute url

templates/widgets/aform/aform.hamlet

@@ -0,0 +1,23 @@
+$newline never
+#{fragment}
+$case formLayout
+  $of FormDBTablePagesize
+    $forall view <- fieldViews
+      <label .form-group__label.label-pagesize for=#{fvId view}>#{fvLabel view}
+      ^{fvInput view}
+  $of _
+    $forall view <- fieldViews
+      $if fvId view == idFormSectionNoinput
+        <h3 .form-section-title>
+          ^{fvLabel view}
+      $else
+        <div .form-group :fvRequired view:.form-group--required :not $ fvRequired view:.form-group--optional :isJust $ fvErrors view:.form-group--has-error>
+          $if not (Blaze.null $ fvLabel view)
+            <label .form-group__label for=#{fvId view}>
+              #{fvLabel view}
+              $maybe hint <- fvTooltip view
+                <div .form-group__hint>^{hint}
+          <div .form-group__input>
+            ^{fvInput view}
+            $maybe err <- fvErrors view
+              <div .form-error>#{err}

templates/widgets/form/form.hamlet

@@ -1,23 +1,14 @@
 $newline never
-#{fragment}
+$# Wrapper for all kinds of forms
-$case formLayout
+<form ##{formId} method=#{decodeUtf8 formMethod} action=#{formActionUrl} enctype=#{formEncoding}>
-  $of FormDBTablePagesize
+  $# Distinguish different falvours of submit button layouts here:
-    $forall view <- fieldViews
+  $case formSubmit
-      <label .form-group__label.label-pagesize for=#{fvId view}>#{fvLabel view}
+    $of FormNoSubmit
-      ^{fvInput view}
+      ^{formWidget}
-  $of _
+    $of FormSubmit
-    $forall view <- fieldViews
+      ^{formWidget}
-      $if fvId view == idFormSectionNoinput
+      ^{submitButtonView}
-        <h3 .form-section-title>
+    $of FormDualSubmit
-          ^{fvLabel view}
+      ^{submitButtonView}
-      $else
+      ^{formWidget}
-        <div .form-group :fvRequired view:.form-group--required :not $ fvRequired view:.form-group--optional :isJust $ fvErrors view:.form-group--has-error>
+      ^{submitButtonView}
-          $if not (Blaze.null $ fvLabel view)
-            <label .form-group__label for=#{fvId view}>
-              #{fvLabel view}
-              $maybe hint <- fvTooltip view
-                <div .form-group__hint>^{hint}
-          <div .form-group__input>
-            ^{fvInput view}
-            $maybe err <- fvErrors view
-              <div .form-error>#{err}

templates/widgets/form/form.julius

@@ -1,5 +1,3 @@
 document.addEventListener('DOMContentLoaded', function() {
-  Array.from(document.querySelectorAll('form')).forEach(function(form) {
+  window.utils.setup('form', document.querySelector('#' + #{String formId}));
-    window.utils.setup('form', form);
-  });
 });