MFormGroups okay, AFormGroups just a silly workaround

src/Handler/Profile.hs

@@ -28,8 +28,16 @@ data SettingsForm = SettingsForm
 
 makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
 makeSettingForm template = identForm FIDsettings $ \html -> do
-    let themeList = [Option (display t) t (toPathPiece t) | t <- universeF]
-    (result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
+    (result, widget) <- flip (renderAForm FormStandard) html $ settingsFormT5T2
+      <$> aFormGroup "Cosmetics"     cosmeticsForm
+      <*> aFormGroup "Notifications" notificationsForm
+      <*  submitButton
+    return (result, widget) -- no validation required here
+  where
+    settingsFormT5T2 :: (Int,Theme,DateTimeFormat,DateTimeFormat,DateTimeFormat) -> (Bool,NotificationSettings) -> SettingsForm
+    settingsFormT5T2 = $(uncurryN 2) . $(uncurryN 5) SettingsForm
+    themeList = [Option (display t) t (toPathPiece t) | t <- universeF]
+    cosmeticsForm = do (,,,,)
       <$> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here
             (fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template)
       <*> areq (selectField . return $ mkOptionList themeList)
@@ -37,16 +45,13 @@ makeSettingForm template = identForm FIDsettings $ \html -> do
       <*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template)
       <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) (stgDate <$> template)
       <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) (stgTime <$> template)
-      <*> areq checkBoxField (fslI MsgDownloadFiles
+    notificationsForm = (,)
+      <$> areq checkBoxField (fslI MsgDownloadFiles
                                & setTooltip MsgDownloadFilesTip
                              ) (stgDownloadFiles <$> template)
       <*> (NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True)
-      <*  submitButton
-    return (result, widget) -- no validation required here
-  where
     nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt . stgNotificationSettings <$> template)
 
-
 getProfileR, postProfileR :: Handler Html
 getProfileR = postProfileR
 postProfileR = do

src/Handler/Utils/Form.hs

@@ -39,6 +39,7 @@ import Control.Monad.Writer.Class
 import Data.Scientific (Scientific)
 import Data.Ratio
 import Text.Read (readMaybe)
+import Text.Blaze (ToMarkup)
 
 import Utils.Lens
 
@@ -630,3 +631,37 @@ 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}|]
+                      }
+
+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

@@ -5,6 +5,7 @@ module Utils.Form where
 import ClassyPrelude.Yesod hiding (addMessage, cons, Proxy(..))
 import Settings
 
+-- import Text.Blaze (toMarkup) -- for debugging
 import qualified Text.Blaze.Internal as Blaze (null)
 import qualified Data.Text as T
 
@@ -40,6 +41,9 @@ 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)

src/Utils/TH.hs

@@ -24,7 +24,7 @@ projNI n i = lamE [pat] rhs
   where pat = tupP (map varP xs)
         rhs = varE (xs !! (i - 1))
         xs  = [ mkName $ "x" ++ show j | j <- [1..n] ]
-        
+
 ---------------
 -- Functions --
 ---------------
@@ -34,21 +34,38 @@ permuteFun perm = lamE pat rhs
   where pat = map varP $ fn:xs
         rhs = foldl appE (varE fn) $ map varE ps
 --         rhs = appE (varE fn) (varE $ xs!!1)
-        ln  = length perm   
+        ln  = length perm
         xs  = [ mkName $ "x" ++ show j | j <- [1..ln] ]
         ps  = [ xs !! (j-1) | j <- perm ]
-        fn  = mkName "fn" 
+        fn  = mkName "fn"
 
 altFun :: [Int] -> ExpQ -- generic permutation/repetition of function arguments, i.e. $(permuteFun [2,1]) == flip
 altFun perm = lamE pat rhs
   where pat = map varP $ fn:xs
         rhs = foldl appE (varE fn) $ map varE ps
---         rhs = appE (varE fn) (varE $ xs!!1)        
+--         rhs = appE (varE fn) (varE $ xs!!1)
         mx  = maximum $ impureNonNull perm
         xs  = [ mkName $ "x" ++ show j | j <- [1..mx] ]
         ps  = [ xs !! (j-1) | j <- perm ]
-        fn  = mkName "fn" 
-        
+        fn  = mkName "fn"
+
+-- |
+curryN :: Int -> ExpQ
+curryN n = do
+  fn <- newName "foo"
+  xs <- replicateM n $ newName "x"
+  let pat = map VarP (fn:xs)
+  let tup = TupE (map VarE xs)
+  let rhs = AppE (VarE fn) tup
+  return $ LamE pat rhs
+
+uncurryN :: Int -> ExpQ
+uncurryN n = do
+  fn <- newName "foo"
+  xs <- replicateM n $ newName "x"
+  let pat = [VarP fn, TupP (map VarP xs)]
+  let rhs = foldl AppE (VarE fn) (map VarE xs)
+  return $ LamE pat rhs
 
 
 -- Special Show-Instances for Themes
@@ -105,10 +122,10 @@ embedRenderMessage f inner mangle = do
 
   f' <- newName "f"
   ls <- newName "ls"
-  
+
   pure <$> instanceD (cxt []) [t|RenderMessage $(conT f) $(conT inner)|]
     [ funD 'renderMessage
-      [ clause [varP f', varP ls] (normalB $ [e|renderMessage $(varE f') $(varE ls) . $(lamCaseE matches)|]) [] 
+      [ clause [varP f', varP ls] (normalB $ [e|renderMessage $(varE f') $(varE ls) . $(lamCaseE matches)|]) []
       ]
     ]
 
@@ -129,13 +146,13 @@ embedRenderMessageVariant f newT mangle = do
 
   f' <- newName "f"
   ls <- newName "ls"
-  
+
   pure <$> instanceD (cxt []) [t|RenderMessage $(conT f) $(conT newT)|]
     [ funD 'renderMessage
-      [ clause [varP f', varP ls] (normalB $ [e|renderMessage $(varE f') $(varE ls) . $(lamCaseE matches)|]) [] 
+      [ clause [varP f', varP ls] (normalB $ [e|renderMessage $(varE f') $(varE ls) . $(lamCaseE matches)|]) []
       ]
     ]
-  
+
 
 dispatchTH :: Name -- ^ Datatype to pattern match
            -> ExpQ

templates/widgets/aform-group.hamlet

@@ -0,0 +1,8 @@
+$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

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