From e3f2eb8ccfc5f33f1eb0359cd853737656ced2b4 Mon Sep 17 00:00:00 2001 From: Andrew Martin Date: Tue, 26 Sep 2017 15:12:15 -0400 Subject: [PATCH] add paginatedExpandable --- .../src/Reflex/Dom/Colonnade.hs | 109 +++++++++++++++++- 1 file changed, 103 insertions(+), 6 deletions(-) diff --git a/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs b/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs index f30534a..a0bf2be 100644 --- a/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs +++ b/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs @@ -39,6 +39,7 @@ module Reflex.Dom.Colonnade -- , expandableResizableTableless , sectioned , paginated + , paginatedExpandable -- * Cell Functions , cell , charCell @@ -583,6 +584,9 @@ expandable tableAttrs tdExpandedAttrs as encoding@(E.Colonnade v) = do data Visible a = Visible !Bool a -- TODO: figure out a way to get rid of the awful default value hack +-- It would be nice to use foldDynMaybeM, but we still need an initial +-- value. We could try to wait to generate the rows until we've seen +-- a value, but that seems confusing. paginated :: forall t b h m a c. (Sizable t b h, Cellular t m c, Headedness b, MonadFix m, Functor h) => Bureau t b a -- ^ table class settings @@ -624,15 +628,63 @@ paginated (Bureau tableAttrs theadAttrs bodyAttrs trAttrs) (Pagination pageSize makePagination totalPages return () _ -> error "Reflex.Dom.Colonnade: paginated: write this code" + +-- | A paginated table with a fixed number of rows. Each row can +-- expand a section beneath it, represented as an additional +-- table row. CSS rules that give the table a striped appearance +-- are unlikely to work since there are hidden rows. +paginatedExpandable :: forall t b h m a c. + (Sizable t b h, Cellular t m c, Headedness b, MonadFix m, Functor h, MonadHold t m) + => Bureau t b a -- ^ table class settings + -> Pagination t m -- ^ pagination settings + -> a -- ^ An inhabitant of type @a@ only used for the cells in hidden rows. + -> (Dynamic t a -> m ()) -- expandable extra content + -> Colonnade h (Dynamic t a) (c (Dynamic t Bool)) + -- ^ Column blueprint. The boolean event enables and disables the expansion. + -> Dynamic t (Vector a) -- ^ table row data + -> m () +paginatedExpandable (Bureau tableAttrs theadAttrs bodyAttrs trAttrs) (Pagination pageSize arrange makePagination) aDef expansion col vecD = do + let colLifted :: Colonnade h (Dynamic t (Visible a)) (c (Dynamic t Bool)) + colLifted = PF.lmap (fmap (\(Visible _ a) -> a)) col + expansionLifted :: Dynamic t (Visible a) -> m () + expansionLifted = expansion . fmap (\(Visible _ a) -> a) + makeVals :: Dynamic t Int -> Vector (Dynamic t (Visible a)) + makeVals page = V.generate pageSize $ \ix -> do + p <- page + v <- vecD + return (maybe (Visible False aDef) (Visible True) (v V.!? (p * pageSize + ix))) + totalPages :: Dynamic t Int + totalPages = fmap ((`divRoundUp` pageSize) . V.length) vecD + hideWhenUnipage :: Dynamic t (Map Text Text) -> Dynamic t (Map Text Text) + hideWhenUnipage = zipDynWith + ( \ct attrs -> if ct > 1 then attrs else M.insert "style" "display:none;" attrs + ) totalPages + trAttrsLifted :: Visible a -> Dynamic t (Map Text Text) + trAttrsLifted (Visible _ a) = trAttrs a + size :: Dynamic t Int + size = coerceDynamic (foldMap (\x -> coerceDynamic (sizableSize (E.oneColonnadeHead x)) :: Dynamic t (Sum Int)) (E.getColonnade col)) + elDynAttr "table" tableAttrs $ case arrange of + ArrangementFooter tfootAttrs tfootTrAttrs tfootThAttrs -> mdo + tableHeader theadAttrs colLifted + let vals = makeVals page + tableBodyExpandable size expansionLifted bodyAttrs trAttrsLifted colLifted vals + page <- elDynAttr "tfoot" (hideWhenUnipage tfootAttrs) $ do + elDynAttr "tr" tfootTrAttrs $ do + let attrs = zipDynWith insertSizeAttr size tfootThAttrs + elDynAttr "th" attrs $ do + makePagination totalPages + return () + _ -> error "Reflex.Dom.Colonnade: paginated: write this code" + divRoundUp :: Int -> Int -> Int divRoundUp a b = case divMod a b of (x,y) -> if y == 0 then x else x + 1 -tableHeader :: forall t b h c a m. +tableHeader :: forall t b h c a m x. (Reflex t, Sizable t b h, Cellular t m c, Headedness b) => b (Dynamic t (Map Text Text), Dynamic t (Map Text Text)) - -> Colonnade h a (c ()) + -> Colonnade h a (c x) -> m () tableHeader theadAttrsWrap col = case headednessExtractForall of Nothing -> return () @@ -642,7 +694,7 @@ tableHeader theadAttrsWrap col = case headednessExtractForall of elDynAttr "tr" trAttrs $ do headerMonadicGeneralSizable_ col (extract . sizableCast (Proxy :: Proxy t)) where - extract :: forall x. b x -> x + extract :: forall y. b y -> y extract = E.runExtractForall extractForall tableBody :: (DomBuilder t m, PostBuild t m, Foldable f, Monoid e, Cellular t m c, Sizable t b h) @@ -657,9 +709,41 @@ tableBody bodyAttrs trAttrs col collection = return (mappend m e) ) mempty collection +-- | This function has a implementation that is careful to only +-- redraw the expansion rows, which are usually hidden, when +-- it is necessary to do so. +tableBodyExpandable :: forall t m c b a h. (DomBuilder t m, MonadHold t m, PostBuild t m, Cellular t m c, Sizable t b h) + => Dynamic t Int -- ^ number of visible columns in the table + -> (Dynamic t a -> m ()) + -> Dynamic t (M.Map T.Text T.Text) + -> (a -> Dynamic t (M.Map T.Text T.Text)) + -> Colonnade h (Dynamic t a) (c (Dynamic t Bool)) + -> Vector (Dynamic t a) + -> m () +tableBodyExpandable colCount renderExpansion bodyAttrs trAttrs col collection = + elDynAttr "tbody" bodyAttrs $ mapM_ (\a -> do + let attrs = trAttrs =<< a + expanded <- elDynAttr "tr" attrs (rowSizableReified (return False) (zipDynWith (||)) col a) + visibleVal <- gateDynamic expanded a + elDynAttr "tr" attrs $ do + -- TODO: possibly provide a way to customize these attributes + let expansionTdAttrs = pure M.empty + elDynAttr "td" (zipDynWith insertSizeAttr colCount expansionTdAttrs) (renderExpansion visibleVal) + ) collection + +-- | Create a dynamic whose value only updates when the gate is 'True'. +-- This dynamic starts out with the original value of its input +-- regardless of whether the gate is true or false. +gateDynamic :: (MonadHold t m, Reflex t) => Dynamic t Bool -> Dynamic t a -> m (Dynamic t a) +gateDynamic g a = do + a0 <- sample (current a) + -- TODO: throw a nubDynWith in here + let e = fmapMaybe id (updated (zipDynWith (\b v -> if b then Just v else Nothing) g a)) + holdDyn a0 e + headerMonadicGeneralSizable_ :: (Sizable t b h, Cellular t m c) - => Colonnade h a (c ()) - -> (h (c ()) -> c ()) + => Colonnade h a (c x) + -> (h (c x) -> c x) -> m () headerMonadicGeneralSizable_ (E.Colonnade v) extract = V.mapM_ go v @@ -670,6 +754,19 @@ headerMonadicGeneralSizable_ (E.Colonnade v) extract = attrs = zipDynWith insertSizeAttr (sizableSize h) (cellularAttrs c) elDynAttr "th" attrs (cellularContents c) +rowSizableReified :: (Sizable t b h, Cellular t m c) + => e -- ^ identity element + -> (e -> e -> e) -- ^ associative append + -> Colonnade h a (c e) + -> a + -> m e +rowSizableReified theEmpty theAppend (E.Colonnade v) a = V.foldM (\m oc -> do + let c = E.oneColonnadeEncode oc a + e <- elDynAttr "td" (cellularAttrs c) $ do + cellularContents c + return (theAppend m e) + ) theEmpty v + rowSizable :: (Sizable t b h, Cellular t m c, Monoid e) => Colonnade h a (c e) -> a @@ -687,7 +784,7 @@ insertSizeAttr i m | otherwise = M.insert "colspan" (T.pack (show i)) m -- | only used internally for implementations of 'Pagination'. -data Movement = Forward | Backward | Position !Int +data Movement = Forward | Backward | Position {-# UNPACK #-} !Int -- | Pagination using the classes and DOM layout that Semantic UI -- expects. The function will typically be partially applided