Filtering refactored with prismAForm

src/Handler/Corrections.hs

@@ -501,11 +501,11 @@ postCorrectionsR = do
         , colRated
         ] -- Continue here
       filterUI = Just $ \mPrev -> mconcat
-        [ Map.singleton "course"       . maybeToList <$> aopt (lift `hoistField` selectField courseOptions) (fslI MsgCourse)       (Just <$> listToMaybe =<< Map.lookup "course" =<< mPrev)
-        , Map.singleton "term"         . maybeToList <$> aopt (lift `hoistField` selectField termOptions)   (fslI MsgTerm)         (Just <$> listToMaybe =<< Map.lookup "term"   =<< mPrev)
-        , Map.singleton "school"       . maybeToList <$> aopt (lift `hoistField` selectField schoolOptions) (fslI MsgCourseSchool) (Just <$> listToMaybe =<< Map.lookup "school" =<< mPrev)
-        , Map.singleton "sheet-search" . maybeToList <$> aopt (lift `hoistField` searchField False)         (fslI MsgSheet)        (Just <$> listToMaybe =<< Map.lookup "sheet-search" =<< mPrev)
-        , Map.singleton "israted" . fmap toPathPiece . maybeToList <$> aopt boolField                       (fslI MsgRatingTime)   (Just <$> fromPathPiece =<< listToMaybe =<< Map.lookup "israted"  =<< mPrev)
+        [ prismAForm (singletonFilter "course" ) mPrev $ aopt (lift `hoistField` selectField courseOptions) (fslI MsgCourse)
+        , prismAForm (singletonFilter "term"   ) mPrev $ aopt (lift `hoistField` selectField termOptions)   (fslI MsgTerm)
+        , prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectField schoolOptions) (fslI MsgCourseSchool)
+        , Map.singleton "sheet-search" . maybeToList <$> aopt (lift `hoistField` searchField False)         (fslI MsgSheet)        (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev)))
+        , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt boolField                        (fslI MsgRatingTime)
         ]
       courseOptions = runDB $ do
         courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)

src/Handler/Course.hs

@@ -176,8 +176,8 @@ makeCourseTable whereClause colChoices psValidator = do
           )
         ]
     , dbtFilterUI = \mPrev -> mconcat $ catMaybes
-      [ Just $ Map.singleton "search" . maybeToList <$> aopt (searchField True) (fslI MsgCourseFilterSearch) (Just <$> listToMaybe =<< Map.lookup "search" =<< mPrev)
-      , muid $> (Map.singleton "registered" . fmap toPathPiece . maybeToList <$> aopt boolField (fslI MsgCourseFilterRegistered) (Just <$> fromPathPiece =<< listToMaybe =<< Map.lookup "registered" =<< mPrev))
+      [ Just  $ prismAForm (singletonFilter "search") mPrev $ aopt (searchField True) (fslI MsgCourseFilterSearch)
+      , muid $> prismAForm (singletonFilter "registered" . maybePrism _PathPiece) mPrev (aopt boolField (fslI MsgCourseFilterRegistered))
       ]
     , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
     , dbtParams = def

src/Handler/Utils/Table/Pagination.hs

@@ -9,6 +9,7 @@ module Handler.Utils.Table.Pagination
   , DBRow(..), _dbrOutput, _dbrIndex, _dbrCount
   , DBStyle(..), defaultDBSFilterLayout, DBEmptyStyle(..)
   , DBTable(..), IsDBTable(..), DBCell(..)
+  , singletonFilter
   , DBParams(..)
   , cellAttrs, cellContents
   , PagesizeLimit(..)
@@ -358,6 +359,15 @@ defaultDBSFilterLayout :: Widget -- ^ Filter UI
                        -> Widget
 defaultDBSFilterLayout filterWgdt filterEnctype filterAction scrolltable = $(widgetFile "table/layout-filter-default")
 
+
+singletonFilter :: Ord k => k -> Prism' (Map k [v]) (Maybe v)
+-- ^ for use with @prismAForm@
+singletonFilter key = prism' fromInner (fmap Just . fromOuter)
+    where
+      fromInner = maybe Map.empty $ Map.singleton key . pure
+      fromOuter = Map.lookup key >=> listToMaybe
+
+
 data DBTable m x = forall a r r' h i t k k'.
   ( ToSortable h, Functor h
   , E.SqlSelect a r, SqlIn k k', DBTableKey k'

src/Utils/Form.hs

@@ -447,3 +447,9 @@ hoistField f Field{..} = Field
   , fieldView
   , fieldEnctype
   }
+
+prismAForm :: Monad m => Prism' s a -> Maybe s ->  (Maybe a -> AForm m a) -> AForm m s
+-- ^ @Monad m => Prism' s a -> (Maybe a -> AForm m a) -> (Maybe s -> AForm m s)@
+prismAForm p outer form = review p <$> form inner
+  where
+    inner = outer >>= preview p

src/Utils/Lens.hs

@@ -10,6 +10,12 @@ import qualified Database.Esqueleto as E (Value(..),InnerJoin(..))
 _unValue :: Lens' (E.Value a) a
 _unValue f (E.Value a) = E.Value <$> f a
 
+_PathPiece :: PathPiece v => Prism' Text v
+_PathPiece = prism' toPathPiece fromPathPiece
+
+maybePrism :: Prism' a b -> Prism' (Maybe a) (Maybe b)
+maybePrism p = prism' (fmap $ review p) (fmap $ preview p )
+
 _InnerJoinLeft :: Lens' (E.InnerJoin l r) l -- forall f. Functor f => (a -> f a) -> s -> f s
 _InnerJoinLeft  f (E.InnerJoin l r) = (`E.InnerJoin` r) <$> f l