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);