diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 742a21407..ae7240831 100644 --- a/src/Handler/Utils/Form.hs +++ b/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} -

#{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 19e8e3cb8..761afbe02 100644 --- a/src/Utils/Form.hs +++ b/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 + + diff --git a/templates/formPageI18n.hamlet b/templates/formPageI18n.hamlet index bf8b877ca..bbdc87853 100644 --- a/templates/formPageI18n.hamlet +++ b/templates/formPageI18n.hamlet @@ -1,5 +1,5 @@ $maybe text <- formText -

+

_{text}
^{formWidget} diff --git a/templates/widgets/aform-group.hamlet b/templates/widgets/aform-group.hamlet deleted file mode 100644 index 4a868bd14..000000000 --- a/templates/widgets/aform-group.hamlet +++ /dev/null @@ -1,8 +0,0 @@ -$newline never -

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