Embrace collisions in dbtable auxiliary tables

package.yaml

@@ -162,6 +162,7 @@ default-extensions:
   - PolyKinds
   - PackageImports
   - TypeApplications
+  - RecursiveDo
 
 ghc-options:
   - -Wall

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
+    , dbtFilterUI = \mPrev -> mconcat
-      [ Map.singleton "search" . maybeToList <$> aopt textField (fslI MsgCourseFilterSearch) Nothing
+      [ Map.singleton "search" . maybeToList <$> aopt textField (fslI MsgCourseFilterSearch) (Just <$> listToMaybe =<< Map.lookup "search" =<< mPrev)
-      , Map.singleton "registered" . fmap toPathPiece . maybeToList <$> aopt boolField (fslI MsgCourseFilterRegistered) Nothing
+      , Map.singleton "registered" . fmap toPathPiece . maybeToList <$> aopt boolField (fslI MsgCourseFilterRegistered) (Just <$> fromPathPiece =<< listToMaybe =<< Map.lookup "registered" =<< mPrev)
       ]
     , dbtStyle = def
     , dbtParams = def

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
+data WithIdent x = forall ident. PathPiece ident => WithIdent { _ident :: ident, _withoutIdent :: x }
-addPIHiddenFields DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } pi pKeys form fragment = do
+
+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
+      <input type=hidden name=#{wIdent "pagination"} value=#{encodeToTextBuilder pi}>
+    |]
+  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
-    <input type=hidden name=#{wIdent "pagination"} value=#{encodeToTextBuilder pi}>
     <input type=hidden name=#{wIdent "previous"} value=#{encrypted}>
   |]
   where
-    wIdent n
+    wIdent :: Text -> Text
-      | not $ null dbtIdent = dbtIdent <> "-" <> n
+    wIdent = toPathPiece . WithIdent dbtIdent
-      | otherwise           = n
 
 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
+    wIdent :: Text -> Text
-      | not $ null dbtIdent = dbtIdent <> "-" <> n
+    wIdent = toPathPiece . WithIdent dbtIdent 
-      | otherwise           = n
     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 $ (,)
+  (((filterRes, filterWdgt), filterEnc), ((pagesizeRes, pagesizeWdgt), pagesizeEnc)) <- mdo
-    <$> areq (jsonField True) ("" & addName (wIdent "pagination-base")) (Just $ prevPi & _piFilter .~ Nothing & _piPage .~ Nothing)
+    (filterRes'@((filterRes, _), _)) <- runFormGet . identForm FIDDBTableFilter . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi)
-    <*> dbtFilterUI
 
-  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 $ (,)
+    (pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identForm FIDDBTablePagesize . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . 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)
-    <*> areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addAutosubmit & addName (wIdent "pagesize") & addClass "select--pagesize") (Just referencePagesize)
+      <*  autosubmitButton
-    <*  autosubmitButton
+    return (filterRes', pagesizeRes')
 
   let
-    piResult = piPreviousRes
+    piResult = (\fSettings -> prevPi & _piFilter .~ Just fSettings) <$> filterRes
-           <|> (\(prev, fSettings) -> prev & _piFilter .~ Just fSettings) <$> filterRes
+           <|> (\ps -> prevPi & _piLimit .~ Just ps) <$> pagesizeRes
-           <|> (\(prev, ps) -> prev & _piLimit .~ Just ps) <$> pagesizeRes
+           <|> piPreviousRes
            <|> piInput
 
   psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit

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

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

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

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