Code cleaning done.

src/Handler/Utils/Form.hs

@@ -39,8 +39,6 @@ import Control.Monad.Writer.Class
 import Data.Scientific (Scientific)
 import Data.Ratio
 import Text.Read (readMaybe)
-import Text.Blaze (ToMarkup)
-import Text.Hamlet (shamletFile)
 
 import Utils.Lens
 
@@ -289,7 +287,6 @@ multiFileField permittedFiles' = Field{..}
       Right _ -> return ()
       Left  r -> yield r
 
-
 data SheetGrading' = Points' | PassPoints' | PassBinary'
   deriving (Eq, Ord, Read, Show, Enum, Bounded)
 
@@ -632,65 +629,3 @@ formResultModal res finalDest handler = maybeT_ $ do
     | otherwise -> do
         forM_ messages $ \Message{..} -> addMessage messageClass messageContent
         redirect finalDest
-
-
--- TODO / WIP: form groups, needs cleanup once it works
-infoField :: (Monad m, HandlerSite m ~ UniWorX, ToMarkup t) => t -> Field m () --TODO if kept, move to fields, more likely delete this workaround
-infoField txt = Field { fieldEnctype = UrlEncoded
-                      , fieldParse = const $ const $ return $ Right $ Just ()
-                      , fieldView  = \_theId _name _attrs _val _isReq ->
-                           [whamlet|#{txt}|]
-                      }
-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       = "form-section-noinput"
-      , fvErrors   = Nothing
-      , fvRequired = False
-      , fvInput    = mempty
-      })
-
-formSection' :: (Monad m, ToMarkup t) => t -> MForm m (FormResult (), FieldView site) -- TODO: WIP, delete
-formSection' formSectionTitle = return (FormSuccess (), infoView)
-  where
-    flabel :: Html
-    flabel   = $(shamletFile "./templates/widgets/form-section-title.shamlet") -- TODO: Why must this be fully qualified?
-    infoView = FieldView
-      { fvLabel    = flabel
-      , fvTooltip  = Nothing
-      , fvId       = "form-section-noinput"
-      , fvErrors   = Nothing
-      , fvRequired = False
-      , fvInput    = mempty
-      }
-
-infoForm :: Text -> Form () -- TODO: WIP, delete
-infoForm infoText csrf =
-  let widget = [whamlet|#{csrf}
-                <h3 .form-group-title>#{infoText}
-               |]
-  in  return (FormSuccess (), widget)
-
-aFormGroup :: (MonadHandler m, HandlerSite m ~ UniWorX) => String -> AForm m a -> AForm m a
-aFormGroup groupTitle innerForm =
-  -- THIS IS JUST A WORKAROUND, SERIOUS ATTEMPT COMMENTED OUT BELOW
-   grpHeader *> innerForm
-  where
-    emptyT :: Text
-    emptyT = ""
-    grpHeader = aopt (infoField emptyT) (fromString groupTitle) Nothing
-  -- -- attempt through double converision
-  -- where mInner = do
-  --   let (result, ($ []) -> fieldViews) = aFormToForm innerForm
-  --   return (result, $(widgetFile "widgets/aform-group"))
-
-formGroup :: Text -> Form a -> Form a
-formGroup groupTitle innerForm csrf = do
-  (result,fGroup) <- innerForm csrf
-  return (result,$(widgetFile "widgets/form-group"))

src/Utils/Form.hs

@@ -41,13 +41,42 @@ data FormLayout = FormStandard | FormDBTableFilter | FormDBTablePagesize
 
 renderAForm :: Monad m => FormLayout -> FormRender m a
 renderAForm formLayout aform fragment = do
-  -- let lab1 :: Text
-  --     lab1 = "LABEL"
-  -- let demo = [FieldView (toMarkup lab1) Nothing "someID" [whamlet|FIELD|] Nothing False]
   (res, ($ []) -> fieldViews) <- aFormToForm aform
   let widget = $(widgetFile "widgets/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
+      })
+
+
 --------------------
 -- Field Settings --
 --------------------
@@ -317,6 +346,13 @@ autosubmitButton = combinedButtonFieldF_ (Proxy @ButtonSubmit) $ "" & addAutosub
 -- Custom Fields --
 -------------------
 
+-- | empty field that has no view and always succeeds, useful for form sections having only a label
+noinputField :: Monad m => Field m ()
+noinputField = Field  { fieldEnctype = UrlEncoded
+                      , fieldParse = const $ const $ return $ Right $ Just ()
+                      , fieldView  = \_theId _name _attrs _val _isReq -> mempty
+                      }
+
 ciField :: ( Textual t
            , CI.FoldCase t
            , Monad m
@@ -380,6 +416,26 @@ optionsFinite = do
       }
   return . mkOptionList $ mkOption <$> universeF
 
+-------------------
+-- Special Forms --
+-------------------
+
+aformSection' :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site FormMessage) => SomeMessage site -> AForm m ()
+aformSection' = formToAForm . fmap (second pure) . formSection'
+
+-- | Alternative implementation for 'formSection' in a more standard that shows how allows tooltips and attributs
+formSection' :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site FormMessage) => SomeMessage site -> MForm m (FormResult (), FieldView site) -- TODO: WIP, delete
+formSection' formSectionTitle = mreq noinputField sectionSettings Nothing
+  where
+    sectionSettings = FieldSettings
+      { fsLabel    = formSectionTitle
+      , fsTooltip  = Nothing
+      , fsId       = Just idFormSectionNoinput
+      , fsName     = Nothing
+      , fsAttrs    = [("classy",idFormSectionNoinput)] -- TODO: check if this it useful at all
+      }
+
+
 
 ---------------------
 -- Form evaluation --
@@ -447,3 +503,5 @@ prismAForm :: Monad m => Prism' s a -> Maybe s ->  (Maybe a -> AForm m a) -> AFo
 prismAForm p outer form = review p <$> form inner
   where
     inner = outer >>= preview p
+
+

templates/formPageI18n.hamlet

@@ -1,5 +1,5 @@
 $maybe text <- formText
-  <h3>
+  <h2>
     _{text}
 <form method=post action=@{actionUrl}#forms enctype=#{formEnctype}>
    ^{formWidget}

templates/widgets/aform-group.hamlet

@@ -1,8 +0,0 @@
-$newline never
-<h3 .form-group-title>#{groupTitle} TODO
-<div .form-group>
-  $forall view <- fieldViews
-    <label .form-group__label for=#{fvId view}>
-      #{fvLabel view}
-    <div .form-group__input>
-      ^{fvInput view}

templates/widgets/form-group.hamlet

@@ -1,4 +0,0 @@
-$newline never
-<h3 .form-group-title>#{groupTitle} TODO
-<div .form-group>
-  ^{fGroup}

templates/widgets/form-section-title.shamlet

@@ -1,2 +0,0 @@
-<h3 class=form-section-title>
-  #{formSectionTitle}

templates/widgets/form.hamlet

@@ -7,7 +7,7 @@ $case formLayout
       ^{fvInput view}
   $of _
     $forall view <- fieldViews
-      $if fvId view == "form-section-noinput"
+      $if fvId view == idFormSectionNoinput
         <h3 .form-section-title>
           ^{fvLabel view}
       $else