diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index 787a2e4b5..8c53501f8 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
@@ -44,6 +45,38 @@ renderAForm formLayout aform fragment = do
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
+ })
+
+
--------------------
-- Field Settings --
--------------------
@@ -323,6 +356,13 @@ submitButtonView = do
-- 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
@@ -386,6 +426,24 @@ optionsFinite = do
}
return . mkOptionList $ mkOption <$> universeF
+-------------------
+-- Special Forms --
+-------------------
+
+-- | Alternative implementation for 'aformSection' in a more standard that
+-- allows tooltips and arbitrary attributs. Section header must be given through `fsLabel`
+aformSection' :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site FormMessage) => FieldSettings site -> AForm m ()
+aformSection' = formToAForm . fmap (second pure) . formSection'
+
+-- | Alternative implementation for 'formSection' in a more standard that
+-- allows tooltips and arbitrary attributs. Section header must be given through `fsLabel`
+formSection' :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site FormMessage) =>
+ FieldSettings site -> MForm m (FormResult (), FieldView site) -- TODO: WIP, delete
+formSection' formSectionTitleSettings = mreq noinputField sectionSettings Nothing
+ where
+ sectionSettings = formSectionTitleSettings { fsId = Just idFormSectionNoinput }
+
+
---------------------
-- Form evaluation --
@@ -453,3 +511,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/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/static/css/utils/form.scss b/static/css/utils/form.scss
index 9f330f75c..2c2a56aa2 100644
--- a/static/css/utils/form.scss
+++ b/static/css/utils/form.scss
@@ -11,6 +11,12 @@ fieldset {
margin-bottom: 0;
}
+@media (min-width: 769px) {
+ .form-group__input {
+ grid-column: 2;
+ }
+}
+
[data-autosubmit][type="submit"] {
animation: fade-in 500ms ease-in-out backwards;
animation-delay: 500ms;
diff --git a/static/css/utils/inputs.scss b/static/css/utils/inputs.scss
index b67b5ee65..f30155892 100644
--- a/static/css/utils/inputs.scss
+++ b/static/css/utils/inputs.scss
@@ -13,8 +13,16 @@
border-left: 2px solid transparent;
+ .form-group {
- margin-top: 13px;
+ margin-top: 7px;
}
+
+ + .form-section-title {
+ margin-top: 40px;
+ }
+}
+
+.form-section-title {
+ color: var(--color-fontsec);
}
.form-group__label {
@@ -22,6 +30,12 @@
padding-top: 6px;
}
+.form-group__hint {
+ margin-top: 7px;
+ color: var(--color-fontsec);
+ font-size: 0.9rem;
+}
+
.form-group--required {
.form-group__label::after {
diff --git a/templates/featureList.hamlet b/templates/featureList.hamlet
index 7b9f151c3..92686723e 100644
--- a/templates/featureList.hamlet
+++ b/templates/featureList.hamlet
@@ -14,7 +14,7 @@