feat(forms): allow customisation of user-facing datalist values
This commit is contained in:
Gregor Kleen
parent
692e533da0
commit
412ce98fa0
@ -1,7 +1,7 @@
|
||||
Material -- course material for disemination to course participants
|
||||
course CourseId
|
||||
name (CI Text)
|
||||
type Text Maybe
|
||||
type (CI Text) Maybe
|
||||
description Html Maybe
|
||||
visibleFrom UTCTime Maybe -- Invisible to enrolled participants before
|
||||
lastEdit UTCTime
|
||||
|
||||
@ -23,10 +23,10 @@ dummyForm :: ( RenderMessage site FormMessage
|
||||
, SqlBackendCanRead (YesodPersistBackend site)
|
||||
, Button site ButtonSubmit
|
||||
) => AForm (HandlerT site IO) (CI Text)
|
||||
dummyForm = areq (selectField userList) (fslI MsgDummyIdent) Nothing
|
||||
dummyForm = areq (ciField & addDatalist userList) (fslI MsgDummyIdent & noAutocomplete) Nothing
|
||||
where
|
||||
userList = fmap mkOptionList . runDB $ map toOption <$> selectList [] [Asc UserIdent]
|
||||
toOption (Entity _ User{..}) = Option (CI.original userIdent) userIdent (CI.original userIdent)
|
||||
toOption (Entity _ User{..}) = Option userDisplayName userIdent (CI.original userIdent)
|
||||
|
||||
dummyLogin :: ( YesodAuth site
|
||||
, YesodPersist site
|
||||
|
||||
@ -8,7 +8,7 @@ import qualified Data.Set as Set
|
||||
-- import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Conduit.List as C
|
||||
-- import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
-- import qualified Data.Text.Encoding as Text
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
@ -27,7 +27,7 @@ import System.FilePath (addExtension)
|
||||
|
||||
data MaterialForm = MaterialForm
|
||||
{ mfName :: MaterialName
|
||||
, mfType :: Maybe Text
|
||||
, mfType :: Maybe (CI Text)
|
||||
, mfDescription :: Maybe Html
|
||||
, mfVisibleFrom :: Maybe UTCTime
|
||||
, mfFiles :: Maybe (Source Handler (Either FileId File))
|
||||
@ -42,16 +42,17 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
|
||||
| Just source <- template >>= mfFiles
|
||||
= runConduit $ source .| C.foldMap setIds
|
||||
| otherwise = return Set.empty
|
||||
typeOptions :: WidgetT UniWorX IO (Set Text)
|
||||
typeOptions :: HandlerT UniWorX IO (OptionList (CI Text))
|
||||
typeOptions = do
|
||||
let defaults = Set.fromList $ map mr [MsgMaterialTypeSlides,MsgMaterialTypeCode,MsgMaterialTypeExample]
|
||||
previouslyUsed <- liftHandlerT . runDB $
|
||||
let defaults = Set.fromList $ map (CI.mk . mr) [MsgMaterialTypeSlides,MsgMaterialTypeCode,MsgMaterialTypeExample]
|
||||
previouslyUsed <- runDB $
|
||||
E.select $ E.from $ \material ->
|
||||
E.distinctOnOrderBy [E.asc $ material E.^. MaterialType] $ do
|
||||
E.where_ $ material E.^. MaterialCourse E.==. E.val cid
|
||||
E.&&. E.not_ (E.isNothing $ material E.^. MaterialType)
|
||||
return $ material E.^. MaterialType
|
||||
return $ defaults <> Set.fromList (mapMaybe E.unValue previouslyUsed)
|
||||
return . mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList
|
||||
$ defaults <> Set.fromList (mapMaybe E.unValue previouslyUsed)
|
||||
|
||||
now <- liftIO getCurrentTime
|
||||
let ctime = ceilingQuarterHour now
|
||||
@ -62,7 +63,7 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
|
||||
|
||||
flip (renderAForm FormStandard) html $ MaterialForm
|
||||
<$> areq ciField (fslI MsgMaterialName) (mfName <$> template)
|
||||
<*> aopt (textField & addDatalist typeOptions)
|
||||
<*> aopt (ciField & addDatalist typeOptions)
|
||||
(fslpI MsgMaterialType $ mr MsgMaterialTypePlaceholder)
|
||||
(mfType <$> template)
|
||||
<*> aopt htmlField (fslpI MsgMaterialDescription "Html")
|
||||
@ -126,7 +127,7 @@ getMaterialListR tid ssh csh = do
|
||||
, dbtColonnade = widgetColonnade $ mconcat
|
||||
[ -- dbRow,
|
||||
sortable (Just "type") (i18nCell MsgMaterialType)
|
||||
$ foldMap textCell . materialType . row2material
|
||||
$ foldMap (textCell . CI.original) . materialType . row2material
|
||||
, sortable (Just "name") (i18nCell MsgMaterialName)
|
||||
$ liftA2 anchorCell matLink toWgt . materialName . row2material
|
||||
, sortable (toNothingS "description") mempty
|
||||
|
||||
@ -69,10 +69,10 @@ mkSchoolForm :: Maybe SchoolId -> Maybe SchoolForm -> Form SchoolForm
|
||||
mkSchoolForm mSsh template = renderAForm FormStandard $ SchoolForm
|
||||
<$> maybe (\f fs -> areq f fs (sfShorthand <$> template)) (\ssh f fs -> aforced f fs (unSchoolKey ssh)) mSsh ciField (fslI MsgSchoolShort)
|
||||
<*> areq ciField (fslI MsgSchoolName) (sfName <$> template)
|
||||
<*> (Set.fromList . mapMaybe (fmap CI.mk . assertM' (not . Text.null) . Text.strip) <$> massInputListA (textField & addDatalist ldapOrgs) (const "") (const Nothing) ("ldap-organisations" :: Text) (fslI MsgSchoolLdapOrganisations & setTooltip MsgSchoolLdapOrganisationsTip) False (fmap CI.original . Set.toList . sfOrgUnits <$> template))
|
||||
<*> (Set.fromList . mapMaybe (fmap CI.mk . assertM' (not . Text.null) . Text.strip . CI.original) <$> massInputListA (ciField & addDatalist ldapOrgs) (const "") (const Nothing) ("ldap-organisations" :: Text) (fslI MsgSchoolLdapOrganisations & setTooltip MsgSchoolLdapOrganisationsTip) False (Set.toList . sfOrgUnits <$> template))
|
||||
where
|
||||
ldapOrgs :: WidgetT UniWorX IO (Set (CI Text))
|
||||
ldapOrgs = liftHandlerT . runDB $
|
||||
ldapOrgs :: HandlerT UniWorX IO (OptionList (CI Text))
|
||||
ldapOrgs = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $
|
||||
setOf (folded . _entityVal . _schoolLdapOrgUnit) <$> selectList [] []
|
||||
|
||||
schoolToForm :: SchoolId -> DB (Form SchoolForm)
|
||||
|
||||
@ -340,8 +340,8 @@ tutorialForm cid template html = do
|
||||
) (tfDeregisterUntil <$> template)
|
||||
<*> tutorForm
|
||||
where
|
||||
tutTypeDatalist :: WidgetT UniWorX IO (Set (CI Text))
|
||||
tutTypeDatalist = liftHandlerT . runDB $
|
||||
tutTypeDatalist :: HandlerT UniWorX IO (OptionList (CI Text))
|
||||
tutTypeDatalist = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $
|
||||
fmap (setOf $ folded . _Value) . E.select . E.from $ \tutorial -> do
|
||||
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
||||
return $ tutorial E.^. TutorialType
|
||||
|
||||
@ -651,9 +651,9 @@ examGradingRuleForm prev = multiActionA actions (fslI MsgExamGradingRule) $ clas
|
||||
|
||||
|
||||
pseudonymWordField :: Field Handler PseudonymWord
|
||||
pseudonymWordField = checkMMap doCheck CI.original $ textField & addDatalist (return $ map CI.original pseudonymWordlist)
|
||||
pseudonymWordField = checkMMap doCheck id $ ciField & addDatalist (return $ mkOptionList [ Option w' w w' | w <- pseudonymWordlist, let w' = CI.original w ])
|
||||
where
|
||||
doCheck (CI.mk -> w)
|
||||
doCheck w
|
||||
| Just w' <- find (== w) pseudonymWordlist
|
||||
= return $ Right w'
|
||||
| otherwise
|
||||
@ -900,8 +900,11 @@ utcTimeField = checkMMap (return . localTimeToUTC') utcToLocalTime localTimeFiel
|
||||
|
||||
langField :: Bool -- ^ Only allow values from `appLanguages`
|
||||
-> Field (HandlerT UniWorX IO) Lang
|
||||
langField False = checkBool (all ((&&) <$> not . null <*> T.all Char.isAlpha) . T.splitOn "-") MsgInvalidLangFormat $ textField & addDatalist (return $ toList appLanguages)
|
||||
langField True = selectField . optionsPairs . map (MsgLanguage &&& id) $ toList appLanguages
|
||||
langField False = checkBool langCheck MsgInvalidLangFormat $ textField & addDatalist appLanguagesOpts
|
||||
where langCheck (T.splitOn "-" -> lParts)
|
||||
= all ((&&) <$> not . null <*> T.all Char.isAlpha) lParts
|
||||
&& not (null lParts)
|
||||
langField True = selectField appLanguagesOpts
|
||||
|
||||
jsonField :: ( ToJSON a, FromJSON a
|
||||
, MonadHandler m
|
||||
|
||||
@ -153,22 +153,36 @@ setNameClass fs gName gClass = fs { fsName = Just gName
|
||||
setTooltip :: RenderMessage site msg => msg -> FieldSettings site -> FieldSettings site
|
||||
setTooltip msg fs = fs { fsTooltip = Just $ SomeMessage msg }
|
||||
|
||||
addDatalist :: (PathPiece (Element vals), MonoFoldable vals, Monad m) => WidgetT (HandlerSite m) IO vals -> Field m a -> Field m a
|
||||
addDatalist mValues field = field
|
||||
addDatalist :: MonadHandler m => HandlerT (HandlerSite m) IO (OptionList a) -> Field m a -> Field m a
|
||||
addDatalist mkOptions field = field
|
||||
{ fieldView = \fId fName fAttrs fRes fReq -> do
|
||||
listId <- newIdent
|
||||
values <- map toPathPiece . otoList <$> mValues
|
||||
|
||||
fieldView field fId fName (("list", listId) : fAttrs) fRes fReq
|
||||
|
||||
options <- liftHandlerT $ olOptions <$> mkOptions
|
||||
[whamlet|
|
||||
$newline never
|
||||
<datalist ##{listId}>
|
||||
$forall value <- values
|
||||
<option value=#{value}>
|
||||
$forall Option{optionDisplay, optionExternalValue} <- options
|
||||
<option value=#{optionExternalValue}>
|
||||
#{optionDisplay}
|
||||
|]
|
||||
, fieldParse = fieldParse'
|
||||
}
|
||||
where
|
||||
fieldParse' [t] [] = do
|
||||
readExt <- liftHandlerT $ olReadExternal <$> mkOptions
|
||||
case readExt t of
|
||||
Just v -> return . Right $ Just v
|
||||
Nothing -> fieldParse field [t] []
|
||||
fieldParse' ts fs = fieldParse field ts fs
|
||||
|
||||
noValidate :: FieldSettings site -> FieldSettings site
|
||||
noValidate = addAttr "formnovalidate" ""
|
||||
|
||||
noAutocomplete :: FieldSettings site -> FieldSettings site
|
||||
noAutocomplete = addAttr "autocomplete" "off"
|
||||
|
||||
inputDisabled :: FieldSettings site -> FieldSettings site
|
||||
inputDisabled = addAttr "disabled" ""
|
||||
|
||||
Loading…
Reference in New Issue
Block a user