diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 501cc97b9..fe20fcd4e 100644 --- a/src/Handler/Admin.hs +++ b/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|

Formular Demonstration|] - $(widgetFile "formPage") + wrapForm formWidget FormSettings + { formMethod = methodPost + , formAction = SomeRoute $ AdminTestR :#: FIDAdminDemo + , formEncoding = formEnctype + , formSubmit = FormSubmit + , formAnchor = Just FIDAdminDemo + } showDemoResult diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 2a568432e..5c04eef05 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -45,6 +45,7 @@ import Utils.Lens import Data.Aeson (eitherDecodeStrict') import Data.Aeson.Text (encodeToLazyText) + ---------------------------- -- Buttons (new version ) -- ---------------------------- diff --git a/src/Utils.hs b/src/Utils.hs index a523c723b..20e33348f 100644 --- a/src/Utils.hs +++ b/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) diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 8c53501f8..094397029 100644 --- a/src/Utils/Form.hs +++ b/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 -- ------------------- diff --git a/src/Utils/Route.hs b/src/Utils/Route.hs new file mode 100644 index 000000000..a62e57cb1 --- /dev/null +++ b/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 diff --git a/templates/widgets/aform/aform.hamlet b/templates/widgets/aform/aform.hamlet new file mode 100644 index 000000000..87f40532c --- /dev/null +++ b/templates/widgets/aform/aform.hamlet @@ -0,0 +1,23 @@ +$newline never +#{fragment} +$case formLayout + $of FormDBTablePagesize + $forall view <- fieldViews +