Quick and dirty list of checkboxes for Digestive Functors

checkboxes.hs

-- new splice
dfPlainText :: Monad m => View Text -> Splice m
dfPlainText view = do
	(ref, attrs) <- getRefAttributes Nothing
	let
		ref' = absoluteRef ref view
		value = fieldInputText ref view
		--value = fieldInputBool ref view
	return [X.TextNode value]

-- modify digestiveSplices to have our new splice
digestiveSplices :: MonadIO m => View Text -> [(Text, Splice m)]
digestiveSplices view =
    [ ("dfInput",            dfInput view)
    , ("dfInputList",        dfInputList view)
    , ("dfInputText",        dfInputText view)
    , ("dfInputTextArea",    dfInputTextArea view)
    , ("dfInputPassword",    dfInputPassword view)
    , ("dfInputHidden",      dfInputHidden view)
    , ("dfInputSelect",      dfInputSelect view)
    , ("dfInputSelectGroup", dfInputSelectGroup view)
    , ("dfInputRadio",       dfInputRadio view)
    , ("dfInputCheckbox",    dfInputCheckbox view)
    , ("dfInputFile",        dfInputFile view)
    , ("dfInputSubmit",      dfInputSubmit view)
    , ("dfPlainText",        dfPlainText view)
    , ("dfLabel",            dfLabel view)
    , ("dfForm",             dfForm view)
    , ("dfErrorList",        dfErrorList view)
    , ("dfChildErrorList",   dfChildErrorList view)
    , ("dfSubView",          dfSubView view)
    , ("dfIfChildErrors",    dfIfChildErrors view)
    ]

-- helper functions
listOfCheckboxes :: Eq a => [a] -> [a] -> [(a, Bool)]
listOfCheckboxes allValues selectedValues =
	map (\ x -> (x, elem x selectedValues)) allValues

checkboxForm :: Monad m => Maybe (String, Bool) -> Form Text m (String, Bool)
checkboxForm e = ( , )
	<$> "name" .: string (fst <$> e)
	<*> "item" .: bool (snd <$> e)

checkboxesToList :: [(a, Bool)] -> [a]
checkboxesToList = map fst . filter snd

-- the form
myForm :: (HasPostgres m, Monad m) => Maybe a -> Form Text m (String, Text, Maybe Text, Maybe String, [(LocalTime, LocalTime)], [(String, Bool)])
myForm e = monadic $ do
	allCategories <- categoryList
	return $ ( , , , , , )
		<$> "name" .: string (name <$> e)
		<*> "description" .: text (description <$> e)
		<*> "followup" .: optionalText (followup =<< e)
		<*> "url" .: optionalString (url =<< e)
		<*> "dates" .: listOf eventDateForm (justLocalDates . dates <$> e)
		<*> "categories" .: listOf checkboxForm (Just $ listOfCheckboxes (map fromOnly allCategories) (maybe [] categories e))

-- processing the results
editCategories :: (HasPostgres m, Functor m) => Int64 -> [String] -> [(String, Bool)] -> m (Either ConstraintViolation ())
editCategories i oldCats cx = do
	withTransaction $
		(sequence_  $ map (\ c -> PG.execute [sqlFile|sql/deleteCategory.sql|] (i, c)) removedCats) >>
		(sequence_  $ map (\ c -> PG.execute [sqlFile|sql/insertCategory.sql|] (i, c)) newCats)
	where
		cats = checkboxesToList cx
		--unmodifiedCats = intersect oldCats cats
		newCats = cats \\ oldCats
		removedCats = oldCats \\ cats

checkboxes.tpl

		<dfInputList ref="categories"><ul>
			<dfListItem><li itemAttrs>
				<label> <dfInputCheckbox ref="item" /> <dfPlainText ref="name" /></label>
			</li></dfListItem>
		</ul></dfInputList>