feat(forms): allow customisation of user-facing datalist values

models/materials

@@ -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

src/Auth/Dummy.hs

@@ -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

src/Handler/Material.hs

@@ -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]
+        let defaults = Set.fromList $ map (CI.mk . mr) [MsgMaterialTypeSlides,MsgMaterialTypeCode,MsgMaterialTypeExample]
-        previouslyUsed <- liftHandlerT . runDB $
+        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

src/Handler/School.hs

@@ -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 :: HandlerT UniWorX IO (OptionList (CI Text))
-    ldapOrgs = liftHandlerT . runDB $
+    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)

src/Handler/Tutorial.hs

@@ -340,8 +340,8 @@ tutorialForm cid template html = do
                             ) (tfDeregisterUntil <$> template)
     <*> tutorForm
   where
-    tutTypeDatalist :: WidgetT UniWorX IO (Set (CI Text))
+    tutTypeDatalist :: HandlerT UniWorX IO (OptionList (CI Text))
-    tutTypeDatalist = liftHandlerT . runDB $
+    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

src/Handler/Utils/Form.hs

@@ -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 False = checkBool langCheck MsgInvalidLangFormat $ textField & addDatalist appLanguagesOpts
-langField True = selectField . optionsPairs . map (MsgLanguage &&& id) $ toList appLanguages
+  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

src/Utils/Form.hs

@@ -153,23 +153,37 @@ 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 :: MonadHandler m => HandlerT (HandlerSite m) IO (OptionList a) -> Field m a -> Field m a
-addDatalist mValues field = field
+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
+          $forall Option{optionDisplay, optionExternalValue} <- options
-            <option value=#{value}>
+            <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" ""