diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 38f064dd8..3bd2e0166 100644 --- a/src/Handler/Profile.hs +++ b/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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 152d53186..286a7d451 100644 --- a/src/Handler/Utils/Form.hs +++ b/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} +

#{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")) \ No newline at end of file diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 6fab13a32..19e8e3cb8 100644 --- a/src/Utils/Form.hs +++ b/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) diff --git a/src/Utils/TH.hs b/src/Utils/TH.hs index 501cfee12..ea1e73b3c 100644 --- a/src/Utils/TH.hs +++ b/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 diff --git a/templates/widgets/aform-group.hamlet b/templates/widgets/aform-group.hamlet new file mode 100644 index 000000000..4a868bd14 --- /dev/null +++ b/templates/widgets/aform-group.hamlet @@ -0,0 +1,8 @@ +$newline never +

#{groupTitle} TODO +
+ $forall view <- fieldViews +