From 82b5315c36eb42ad23b1fa6f84b16db583ff3dca Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 24 Jan 2019 16:47:46 +0100 Subject: [PATCH] Filtering refactored with prismAForm --- src/Handler/Corrections.hs | 10 +++++----- src/Handler/Course.hs | 4 ++-- src/Handler/Utils/Table/Pagination.hs | 20 +++++++++++++++----- src/Utils/Form.hs | 6 ++++++ src/Utils/Lens.hs | 6 ++++++ 5 files changed, 34 insertions(+), 12 deletions(-) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 94bb0e07d..6e98a5c38 100644 --- a/src/Handler/Corrections.hs +++ b/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) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index fea34eb3e..53eb08665 100644 --- a/src/Handler/Course.hs +++ b/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 diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 3ef8450e0..3786141bb 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/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(..) @@ -205,7 +206,7 @@ deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 , sumEncoding = UntaggedValue } ''PagesizeLimit - + data PaginationSettings = PaginationSettings { psSorting :: [SortingSetting] @@ -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' @@ -564,7 +574,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db , let t' = toPathPiece $ SortingSetting t d ] wIdent :: Text -> Text - wIdent = toPathPiece . WithIdent dbtIdent + wIdent = toPathPiece . WithIdent dbtIdent dbsAttrs' | not $ null dbtIdent = ("id", dbtIdent) : dbsAttrs | otherwise = dbsAttrs @@ -723,7 +733,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db setParams :: Text -> [Text] -> QueryText -> QueryText setParams key vs qt = map ((key, ) . Just) vs ++ [ i | i@(key', _) <- qt, key' /= key ] - + setParam :: Text -> Maybe Text -> QueryText -> QueryText setParam key = setParams key . maybeToList @@ -756,7 +766,7 @@ pagesizeField psLim = selectField $ do optText (PagesizeLimit l) = tshow l optText PagesizeAll = mr MsgDBTablePagesizeAll - toOptionList = flip OptionList fromPathPiece . map (\o -> Option (optText o) o $ toPathPiece o) . Set.toAscList . Set.fromList + toOptionList = flip OptionList fromPathPiece . map (\o -> Option (optText o) o $ toPathPiece o) . Set.toAscList . Set.fromList return $ toOptionList limOpts where limOpts :: [PagesizeLimit] @@ -852,7 +862,7 @@ formCell resLens genIndex genForm input@(DBRow{dbrKey}) = FormCell mkUnique (toPathPiece -> name) = name <> "-" <> decodeUtf8 (Base64.encode rowKeyHash) where rowKeyHash = (BA.convert :: HMAC (SHAKE256 264) -> ByteString) . hmac hashKey . LBS.toStrict $ B.encode dbrKey - (edit, w) <- genForm input mkUnique + (edit, w) <- genForm input mkUnique return (flip (set resLens) mempty . DBFormResult . Map.singleton i . (input,) <$> edit, w) } diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 696c10644..a7f6d0e31 100644 --- a/src/Utils/Form.hs +++ b/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 diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 7d71d63ef..df1b2c4de 100644 --- a/src/Utils/Lens.hs +++ b/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