Filtering refactored with prismAForm
This commit is contained in:
SJost
parent
38a35a673a
commit
82b5315c36
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
}
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user