diff --git a/package.yaml b/package.yaml index 4bc841965..e480feb22 100644 --- a/package.yaml +++ b/package.yaml @@ -162,6 +162,7 @@ default-extensions: - PolyKinds - PackageImports - TypeApplications + - RecursiveDo ghc-options: - -Wall diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 116a54487..cb0a05f25 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -175,9 +175,9 @@ makeCourseTable whereClause colChoices psValidator = do E.||. (E.castString (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) ) ] - , dbtFilterUI = mconcat - [ Map.singleton "search" . maybeToList <$> aopt textField (fslI MsgCourseFilterSearch) Nothing - , Map.singleton "registered" . fmap toPathPiece . maybeToList <$> aopt boolField (fslI MsgCourseFilterRegistered) Nothing + , dbtFilterUI = \mPrev -> mconcat + [ Map.singleton "search" . maybeToList <$> aopt textField (fslI MsgCourseFilterSearch) (Just <$> listToMaybe =<< Map.lookup "search" =<< mPrev) + , Map.singleton "registered" . fmap toPathPiece . maybeToList <$> aopt boolField (fslI MsgCourseFilterRegistered) (Just <$> fromPathPiece =<< listToMaybe =<< Map.lookup "registered" =<< mPrev) ] , dbtStyle = def , dbtParams = def diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 7ddba89b3..14a613f59 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -343,7 +343,7 @@ data DBTable m x = forall a r r' h i t k k'. , dbtColonnade :: Colonnade h r' (DBCell m x) , dbtSorting :: Map SortingKey (SortColumn t) , dbtFilter :: Map FilterKey (FilterColumn t) - , dbtFilterUI :: AForm (ReaderT SqlBackend (HandlerT UniWorX IO)) (Map FilterKey [Text]) + , dbtFilterUI :: Maybe (Map FilterKey [Text]) -> AForm (ReaderT SqlBackend (HandlerT UniWorX IO)) (Map FilterKey [Text]) , dbtStyle :: DBStyle , dbtParams :: DBParams m x , dbtIdent :: i @@ -452,7 +452,7 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype) -- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget)) - runDBTable dbtable pi pKeys = fmap (view _1) . dbParamsFormEvaluate (dbtParams dbtable) . dbParamsFormWrap (dbtParams dbtable) . addPIHiddenFields dbtable pi pKeys . withFragment + runDBTable dbtable pi pKeys = fmap (view _1) . dbParamsFormEvaluate (dbtParams dbtable) . dbParamsFormWrap (dbtParams dbtable) . addPIHiddenField dbtable pi . addPreviousHiddenField dbtable pKeys . withFragment instance Monoid a => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where def = DBParamsForm @@ -475,18 +475,37 @@ dbParamsFormWrap DBParamsForm{..} tableForm frag = do enctype' = bool id (mappend $ fieldEnctype submitField) dbParamsFormAddSubmit enctype $(widgetFile "table/form-wrap") -addPIHiddenFields :: ToJSON k' => DBTable m x -> PaginationInput -> [k'] -> Form a -> Form a -addPIHiddenFields DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } pi pKeys form fragment = do +data WithIdent x = forall ident. PathPiece ident => WithIdent { _ident :: ident, _withoutIdent :: x } + +instance PathPiece x => PathPiece (WithIdent x) where + toPathPiece (WithIdent ident x) + | not . null $ toPathPiece ident = toPathPiece ident <> "-" <> toPathPiece x + | otherwise = toPathPiece x + fromPathPiece txt = do + let sep = "-" + (ident, (Text.stripSuffix sep -> Just rest)) <- return $ Text.breakOn sep txt + WithIdent <$> pure ident <*> fromPathPiece rest + +addPIHiddenField :: DBTable m' x -> PaginationInput -> (Html -> MForm m a) -> (Html -> MForm m a) +addPIHiddenField DBTable{ dbtIdent } pi form fragment + = form $ fragment <> [shamlet| + $newline never + + |] + where + wIdent :: Text -> Text + wIdent = toPathPiece . WithIdent dbtIdent + +addPreviousHiddenField :: (ToJSON k', MonadHandler m, HandlerSite m ~ UniWorX) => DBTable m' x -> [k'] -> (Html -> MForm m a) -> (Html -> MForm m a) +addPreviousHiddenField DBTable{ dbtIdent } pKeys form fragment = do encrypted <- encodedSecretBox SecretBoxShort pKeys form $ fragment <> [shamlet| $newline never - |] where - wIdent n - | not $ null dbtIdent = dbtIdent <> "-" <> n - | otherwise = n + wIdent :: Text -> Text + wIdent = toPathPiece . WithIdent dbtIdent instance Monoid a => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where mempty = FormCell mempty (return mempty) @@ -505,9 +524,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db , d <- [SortAsc, SortDesc] , let t' = toPathPiece $ SortingSetting t d ] - wIdent n - | not $ null dbtIdent = dbtIdent <> "-" <> n - | otherwise = n + wIdent :: Text -> Text + wIdent = toPathPiece . WithIdent dbtIdent dbsAttrs' | not $ null dbtIdent = ("id", dbtIdent) : dbsAttrs | otherwise = dbsAttrs @@ -517,7 +535,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db , fieldEnctype = UrlEncoded } - piPrevious <- lift . runInputPostMaybe $ ireq (jsonField True) (wIdent "pagination") + piPrevious <- lift . runInputMaybe $ ireq (jsonField True) (wIdent "pagination") let piPreviousRes = maybe FormMissing FormSuccess piPrevious previousKeys <- throwExceptT . runMaybeT $ encodedSecretBoxOpen =<< MaybeT (lift . lookupPostParam $ wIdent "previous") @@ -533,21 +551,20 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db | otherwise = def - ((filterRes, filterWdgt), filterEnc) <- runFormGet . identForm FIDDBTableFilter . renderAForm FormDBTableFilter $ (,) - <$> areq (jsonField True) ("" & addName (wIdent "pagination-base")) (Just $ prevPi & _piFilter .~ Nothing & _piPage .~ Nothing) - <*> dbtFilterUI + (((filterRes, filterWdgt), filterEnc), ((pagesizeRes, pagesizeWdgt), pagesizeEnc)) <- mdo + (filterRes'@((filterRes, _), _)) <- runFormGet . identForm FIDDBTableFilter . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi) - let referencePagesize = psLimit . snd . runPSValidator dbtable $ Just prevPi + let referencePagesize = psLimit . snd . runPSValidator dbtable $ Just prevPi - ((pagesizeRes, pagesizeWdgt), pagesizeEnc) <- lift . runFormGet . identForm FIDDBTablePagesize . renderAForm FormDBTablePagesize $ (,) - <$> areq (jsonField True) ("" & addName (wIdent "pagination-base")) (Just $ prevPi & _piPage .~ Nothing & _piLimit .~ Nothing) - <*> areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addAutosubmit & addName (wIdent "pagesize") & addClass "select--pagesize") (Just referencePagesize) - <* autosubmitButton + (pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identForm FIDDBTablePagesize . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . renderAForm FormDBTablePagesize $ + areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addAutosubmit & addName (wIdent "pagesize") & addClass "select--pagesize") (Just referencePagesize) + <* autosubmitButton + return (filterRes', pagesizeRes') let - piResult = piPreviousRes - <|> (\(prev, fSettings) -> prev & _piFilter .~ Just fSettings) <$> filterRes - <|> (\(prev, ps) -> prev & _piLimit .~ Just ps) <$> pagesizeRes + piResult = (\fSettings -> prevPi & _piFilter .~ Just fSettings) <$> filterRes + <|> (\ps -> prevPi & _piLimit .~ Just ps) <$> pagesizeRes + <|> piPreviousRes <|> piInput psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 2e668a8fd..3240920b8 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -16,6 +16,7 @@ import Yesod.Core.Types as Import (loggerSet) import Yesod.Default.Config2 as Import import Utils as Import import Yesod.Core.Json as Import (provideJson) +import Yesod.Core.Types.Instances as Import () import Data.Fixed as Import diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index db9fa039e..921c82ec5 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -321,6 +321,11 @@ formResultMaybe (FormFailure errs) _ = Nothing <$ forM_ errs (addMessage Error . formResultMaybe FormMissing _ = return Nothing formResultMaybe (FormSuccess res) f = f res +formResult' :: FormResult a -> Maybe a +formResult' FormMissing = Nothing +formResult' (FormFailure _) = Nothing +formResult' (FormSuccess x) = Just x + runInputGetMaybe, runInputPostMaybe, runInputMaybe :: MonadHandler m => FormInput m a -> m (Maybe a) runInputGetMaybe form = do res <- runInputGetResult form diff --git a/src/Yesod/Core/Types/Instances.hs b/src/Yesod/Core/Types/Instances.hs new file mode 100644 index 000000000..e296d0c52 --- /dev/null +++ b/src/Yesod/Core/Types/Instances.hs @@ -0,0 +1,16 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Yesod.Core.Types.Instances + ( + ) where + +import ClassyPrelude +import Yesod.Core.Types + +import Control.Monad.Fix + +instance MonadFix m => MonadFix (HandlerT site m) where + mfix f = HandlerT $ \r -> mfix $ \a -> unHandlerT (f a) r + +instance MonadFix m => MonadFix (WidgetT site m) where + mfix f = WidgetT $ \r -> mfix $ \ ~(a, _) -> unWidgetT (f a) r diff --git a/templates/table/layout.julius b/templates/table/layout.julius index 72a4586fe..38feadbbc 100644 --- a/templates/table/layout.julius +++ b/templates/table/layout.julius @@ -10,12 +10,12 @@ function setupAsync(wrapper) { - var table = wrapper.querySelector('#' + #{String $ dbtIdent}); + var table = wrapper.querySelector('#' + #{String dbtIdent}); if (!table) return; var ths = Array.from(table.querySelectorAll('th.sortable')); - var pagination = wrapper.querySelector('#' + #{String $ dbtIdent} + '-pagination'); + var pagination = wrapper.querySelector('#' + #{String dbtIdent} + '-pagination'); ths.forEach(function(th) { th.addEventListener('click', clickHandler);