From 24a2c1d142826d7108d7726aa250e2ccb9992759 Mon Sep 17 00:00:00 2001 From: Andrew Martin Date: Sun, 24 Sep 2017 22:02:57 -0400 Subject: [PATCH] start using typeclass to make headed vs headless more convenient. add paginated for reflex-dom --- colonnade/src/Colonnade.hs | 2 + colonnade/src/Colonnade/Encode.hs | 50 +++- .../reflex-dom-colonnade.cabal | 27 +- .../src/Reflex/Dom/Colonnade.hs | 262 ++++++++++++++++-- 4 files changed, 294 insertions(+), 47 deletions(-) diff --git a/colonnade/src/Colonnade.hs b/colonnade/src/Colonnade.hs index a09068b..708a1a3 100644 --- a/colonnade/src/Colonnade.hs +++ b/colonnade/src/Colonnade.hs @@ -12,6 +12,8 @@ module Colonnade Colonnade , Headed(..) , Headless(..) + -- * Typeclasses + , E.Headedness(..) -- * Create , headed , headless diff --git a/colonnade/src/Colonnade/Encode.hs b/colonnade/src/Colonnade/Encode.hs index a0811e1..c8c7e10 100644 --- a/colonnade/src/Colonnade/Encode.hs +++ b/colonnade/src/Colonnade/Encode.hs @@ -44,6 +44,9 @@ module Colonnade.Encode , Headed(..) , Headless(..) , Sized(..) + , ExtractForall(..) + -- ** Typeclasses + , Headedness(..) -- ** Row , row , rowMonadic @@ -234,12 +237,13 @@ headerMonadic (Colonnade v) g = fmap (mconcat . Vector.toList) $ Vector.mapM (g . getHeaded . oneColonnadeHead) v headerMonadicGeneral_ :: - (Monad m, Foldable h) + (Monad m, Headedness h) => Colonnade h a c -> (c -> m b) -> m () -headerMonadicGeneral_ (Colonnade v) g = - Vector.mapM_ (mapM_ g . oneColonnadeHead) v +headerMonadicGeneral_ (Colonnade v) g = case headednessExtract of + Nothing -> return () + Just f -> Vector.mapM_ (g . f . oneColonnadeHead) v headerMonoidalGeneral :: (Monoid m, Foldable h) @@ -493,6 +497,10 @@ data MutableSizedColonnade s h a c = MutableSizedColonnade newtype Headed a = Headed { getHeaded :: a } deriving (Eq,Ord,Functor,Show,Read,Foldable) +instance Applicative Headed where + pure = Headed + Headed f <*> Headed a = Headed (f a) + -- | As the first argument to the 'Colonnade' type -- constructor, this indictates that the columnar encoding does not have -- a header. This type is isomorphic to 'Proxy' but is @@ -505,6 +513,10 @@ newtype Headed a = Headed { getHeaded :: a } data Headless a = Headless deriving (Eq,Ord,Functor,Show,Read,Foldable) +instance Applicative Headless where + pure _ = Headless + Headless <*> Headless = Headless + data Sized sz f a = Sized { sizedSize :: !sz , sizedContent :: !(f a) @@ -620,8 +632,38 @@ data AnnotatedCornice sz (p :: Pillar) a c where -- data MaybeInt = JustInt {-# UNPACK #-} !Int | NothingInt --- | This is provided with vector-0.12, but we include a copy here +-- | This is provided with @vector-0.12@, but we include a copy here -- for compatibility. vectorConcatNE :: NonEmpty (Vector a) -> Vector a vectorConcatNE = Vector.concat . toList +-- | This class communicates that a container holds either zero +-- elements or one element. Furthermore, all inhabitants of +-- the type must hold the same number of elements. Both +-- 'Headed' and 'Headless' have instances. The following +-- law accompanies any instances: +-- +-- > maybe x (\f -> f (headednessPure x)) headednessContents == x +-- > todo: come up with another law that relates to Traversable +-- +-- Consequently, there is no instance for 'Maybe', which cannot +-- satisfy the laws since it has inhabitants which hold different +-- numbers of elements. 'Nothing' holds 0 elements and 'Just' holds +-- 1 element. +class Headedness h where + headednessPure :: a -> h a + headednessExtract :: Maybe (h a -> a) + headednessExtractForall :: Maybe (ExtractForall h) + +instance Headedness Headed where + headednessPure = Headed + headednessExtract = Just getHeaded + headednessExtractForall = Just (ExtractForall getHeaded) + +instance Headedness Headless where + headednessPure _ = Headless + headednessExtract = Nothing + headednessExtractForall = Nothing + +newtype ExtractForall h = ExtractForall { runExtractForall :: forall a. h a -> a } + diff --git a/reflex-dom-colonnade/reflex-dom-colonnade.cabal b/reflex-dom-colonnade/reflex-dom-colonnade.cabal index b9f6d2e..e9c79f9 100644 --- a/reflex-dom-colonnade/reflex-dom-colonnade.cabal +++ b/reflex-dom-colonnade/reflex-dom-colonnade.cabal @@ -1,16 +1,16 @@ -name: reflex-dom-colonnade -version: 0.5.0 -synopsis: Use colonnade with reflex-dom -description: Please see README.md -homepage: https://github.com/andrewthad/colonnade#readme -license: BSD3 -license-file: LICENSE -author: Andrew Martin -maintainer: andrew.thaddeus@gmail.com -copyright: 2016 Andrew Martin -category: web -build-type: Simple -cabal-version: >=1.10 +name: reflex-dom-colonnade +version: 0.6.0 +synopsis: Use colonnade with reflex-dom +description: Please see README.md +homepage: https://github.com/andrewthad/colonnade#readme +license: BSD3 +license-file: LICENSE +author: Andrew Martin +maintainer: andrew.thaddeus@gmail.com +copyright: 2016 Andrew Martin +category: web +build-type: Simple +cabal-version: >=1.10 library hs-source-dirs: src @@ -25,6 +25,7 @@ library , reflex == 0.5.* , reflex-dom == 0.4.* , containers >= 0.5 && < 0.6 + , profunctors >= 5.2 && < 5.3 default-language: Haskell2010 source-repository head diff --git a/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs b/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs index ea8e1cd..981f06e 100644 --- a/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs +++ b/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs @@ -3,8 +3,12 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -16,6 +20,9 @@ module Reflex.Dom.Colonnade -- * Types Cell(..) , Resizable(..) + , Bureau(..) + , Arrangement(..) + , Pagination(..) -- * Table Encoders , basic , static @@ -27,8 +34,9 @@ module Reflex.Dom.Colonnade , dynamic , dynamicCapped , expandable - , expandableResizableTableless + -- , expandableResizableTableless , sectioned + , paginated -- * Cell Functions , cell , charCell @@ -37,6 +45,8 @@ module Reflex.Dom.Colonnade , lazyTextCell , builderCell , headedResizable + -- * Other Stuff + , defBureau ) where import Data.String (IsString(..)) @@ -45,20 +55,24 @@ import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Builder as LT import qualified Data.Map.Strict as M import qualified Data.Vector as V +import qualified Data.Profunctor as PF import Data.Map.Strict (Map) +import Data.Vector (Vector) import Data.Text (Text) -import Data.Foldable (Foldable(..),for_,forM_) +import Data.Foldable (Foldable(..),for_,forM_,foldlM) import Data.Traversable (for) import Data.Semigroup (Semigroup(..)) import Control.Applicative (liftA2) import Reflex.Dom -import Colonnade (Colonnade,Headed,Fascia,Cornice) +import Colonnade (Colonnade,Headed,Headless,Fascia,Cornice,Headedness(..)) import Data.Monoid (Sum(..)) +import Data.Proxy +import Control.Monad.Fix (MonadFix) import qualified Colonnade as C import qualified Colonnade.Encode as E data Cell t m b = Cell - { cellAttrs :: !(Dynamic t (M.Map T.Text T.Text)) + { cellAttrs :: !(Dynamic t (M.Map T.Text T.Text)) , cellContents :: !(m b) } deriving (Functor) @@ -67,11 +81,100 @@ data Cell t m b = Cell data Resizable t h b = Resizable { resizableSize :: !(Dynamic t Int) , resizableContent :: !(h b) - } deriving (Foldable) + } deriving (Foldable, Functor) + +data Bureau t h a = Bureau + { bureauTable :: Dynamic t (Map Text Text) + -- ^ attributes of @\@ + , bureauHead :: h (Dynamic t (Map Text Text), Dynamic t (Map Text Text)) + -- ^ attributes of @\@ and of the @\@ inside of it. + , bureauBody :: Dynamic t (Map Text Text) + , bureauRow :: (a -> Dynamic t (Map Text Text)) + -- ^ attributes of each @\@, based on the element + } + -- , bureauHeadRow :: h (Dynamic t (Map Text Text)) + +-- | Where the pagination goes relative to the table +data Arrangement t + = ArrangementAbove + | ArrangementBeneath + | ArrangementFooter + (Dynamic t (Map Text Text)) + (Dynamic t (Map Text Text)) + (Dynamic t (Map Text Text)) + -- ^ contains attributes of @\@, its inner @\@, and its inner @\@. + +-- | The argument to this function is an @Dynamic@ that carries +-- the total number of pages that should be available. When +-- this dynamic changes, it means that the rows backing the +-- table have been changed. Typically, this should cause +-- the @Dynamic@ in the return value to reset to 0. This +-- returned @Dynamic@ represents the current page. +newtype Pagination t m = Pagination { runPagination :: Dynamic t Int -> m (Dynamic t Int) } + +class (PostBuild t m, DomBuilder t m) => Cellular t m c | c -> m, c -> t where + cellularAttrs :: c b -> Dynamic t (Map Text Text) + cellularContents :: c b -> m b + +instance (PostBuild t m, DomBuilder t m) => Cellular t m (Cell t m) where + cellularAttrs = cellAttrs + cellularContents = cellContents + +instance (Reflex t, DomBuilder t m, PerformEvent t m, MonadHold t m, MonadFix m) => Cellular t (PostBuildT t m) (PostBuildT t m) where + cellularAttrs _ = pure M.empty + cellularContents = id + + +-- | This typeclass is provided to make using functions in this +-- library more convenient. The methods could have been passed +-- around in a dictionary instead, but there is only really one +-- sensible implementation for each header type. The only +-- law it should satisfy is: +-- +-- > sizableSize (headednessPure Proxy x) == pure 1 +-- +-- Also, since the instances we are interested in preclude +-- the use of a functional dependency, the typeclass is annoying +-- to use. But, end users should never need to use it. +class Sizable t b h | h -> b where + sizableSize :: h a -> Dynamic t Int + sizableCast :: Proxy t -> h a -> b a + +-- instance (Headedness h, Reflex t) => Headedness (Resizable t h) where +-- headednessPure = Resizable (pure 1) . headednessPure +-- headednessContents = do +-- f <- headednessContents +-- Just (\(Resizable _ a) -> f a) + +instance (Headedness h, Reflex t) => Sizable t h (Resizable t h) where + sizableSize = resizableSize + sizableCast _ (Resizable _ h) = h + +instance Reflex t => Sizable t Headed Headed where + sizableSize _ = pure 1 + sizableCast _ = id + +instance Reflex t => Sizable t Headless Headless where + sizableSize _ = pure 1 + sizableCast _ = id + +defBureau :: forall t h a. (Reflex t, Headedness h) => Bureau t h a +defBureau = Bureau + { bureauTable = pure M.empty + , bureauHead = headednessPure (pure M.empty, pure M.empty) + , bureauBody = pure M.empty + , bureauRow = const (pure M.empty) + } elFromCell :: (DomBuilder t m, PostBuild t m) => T.Text -> Cell t m b -> m b elFromCell e (Cell attr m) = elDynAttr e attr m +-- elFromCellular :: (Cellular t m c, PostBuild t m, DomBuilder t m) +-- => T.Text -- name of the element, @th@ or @td@ +-- -> c b -- cellular value +-- -> m b +-- elFromCellular name c = elDynAttr name (cellularAttrs c) (cellularContents c) + -- | Convenience function for creating a 'Cell' representing -- a @td@ or @th@ with no attributes. cell :: Reflex t => m b -> Cell t m b @@ -121,13 +224,13 @@ basic :: basic tableAttrs = static tableAttrs (Just (M.empty,M.empty)) mempty (const mempty) body :: (DomBuilder t m, PostBuild t m, Foldable f, Monoid e) - => M.Map T.Text T.Text + => Dynamic t (M.Map T.Text T.Text) -> (a -> Dynamic t (M.Map T.Text T.Text)) -> Colonnade h a (Cell t m e) -> f a -> m e body bodyAttrs trAttrs colonnade collection = - elAttr "tbody" bodyAttrs (bodyRows trAttrs colonnade collection) + elDynAttr "tbody" bodyAttrs (bodyRows trAttrs colonnade collection) bodyRows :: (DomBuilder t m, PostBuild t m, Foldable f, Monoid e) => (a -> Dynamic t (M.Map T.Text T.Text)) @@ -160,7 +263,7 @@ setColspanOrHide i m | otherwise = M.insert "colspan" (T.pack (show i)) m static :: - (DomBuilder t m, PostBuild t m, Foldable f, Foldable h, Monoid e) + (DomBuilder t m, PostBuild t m, Foldable f, Headedness h, Monoid e) => M.Map T.Text T.Text -- ^ @\@ tag attributes -> Maybe (M.Map T.Text T.Text, M.Map T.Text T.Text) -- ^ Attributes of @\@ and its @\@, pass 'Nothing' to omit @\@ @@ -174,10 +277,10 @@ static tableAttrs mheadAttrs bodyAttrs trAttrs colonnade collection = for_ mheadAttrs $ \(headAttrs,headTrAttrs) -> elAttr "thead" headAttrs . elAttr "tr" headTrAttrs $ E.headerMonadicGeneral_ colonnade (elFromCell "th") - body bodyAttrs (pure . trAttrs) colonnade collection + body (pure bodyAttrs) (pure . trAttrs) colonnade collection staticTableless :: - (DomBuilder t m, PostBuild t m, Foldable f, Foldable h, Monoid e) + (DomBuilder t m, PostBuild t m, Foldable f, Headedness h, Monoid e) => Maybe (M.Map T.Text T.Text, M.Map T.Text T.Text) -- ^ Attributes of @\@ and its @\@, pass 'Nothing' to omit @\@ -> M.Map T.Text T.Text -- ^ @\@ tag attributes @@ -189,12 +292,12 @@ staticTableless mheadAttrs bodyAttrs trAttrs colonnade collection = do for_ mheadAttrs $ \(headAttrs,headTrAttrs) -> elAttr "thead" headAttrs . elAttr "tr" headTrAttrs $ E.headerMonadicGeneral_ colonnade (elFromCell "th") - body bodyAttrs trAttrs colonnade collection + body (pure bodyAttrs) trAttrs colonnade collection -- | A table dividing into sections by @\@ elements that -- take up entire rows. sectioned :: - (DomBuilder t m, PostBuild t m, Foldable f, Foldable h, Foldable g) + (DomBuilder t m, PostBuild t m, Foldable f, Headedness h, Foldable g) => M.Map T.Text T.Text -- ^ @\@ tag attributes -> Maybe (M.Map T.Text T.Text, M.Map T.Text T.Text) -- ^ Attributes of @\@ and its @\@, pass 'Nothing' to omit @\@ @@ -258,7 +361,7 @@ capped :: capped tableAttrs headAttrs bodyAttrs trAttrs fascia cornice collection = elAttr "table" tableAttrs $ do h <- encodeCorniceHead headAttrs fascia (E.annotate cornice) - b <- body bodyAttrs (pure . trAttrs) (E.discard cornice) collection + b <- body (pure bodyAttrs) (pure . trAttrs) (E.discard cornice) collection return (h `mappend` b) -- | This is useful when you want to be able to toggle the visibility @@ -366,7 +469,7 @@ dynamicBody bodyAttrs trAttrs colonnade dynCollection = unWrappedApplicative . E.rowMonoidal colonnade (WrappedApplicative . elFromCell "td") $ a dynamic :: - (DomBuilder t m, PostBuild t m, Foldable f, Foldable h, Semigroup e, Monoid e) + (DomBuilder t m, PostBuild t m, Foldable f, Headedness h, Semigroup e, Monoid e) => Dynamic t (M.Map T.Text T.Text) -- ^ @\@ tag attributes -> Maybe (Dynamic t (M.Map T.Text T.Text), Dynamic t (M.Map T.Text T.Text)) -- ^ Attributes of @\@ and its @\@, pass 'Nothing' to omit @\@ @@ -438,22 +541,121 @@ expandable tableAttrs tdExpandedAttrs as encoding@(E.Colonnade v) = do return e' widgetHold (return ()) e' -expandableResizableTableless :: forall t m f a b. (MonadWidget t m, Foldable f) - => f a -- ^ Values - -> (Event t b -> m ()) - -- ^ Encoding over additional content - -> Colonnade (Resizable t Headed) a (m (Event t (Maybe b))) - -- ^ Encoding into cells with events that can fire to create additional content under the row +-- expandableResizableTableless :: forall t m f a b. (MonadWidget t m, Foldable f) +-- => f a -- ^ Values +-- -> (Event t b -> m ()) +-- -- ^ Encoding over additional content +-- -> Colonnade (Resizable t Headed) a (m (Event t (Maybe b))) +-- -- ^ Encoding into cells with events that can fire to create additional content under the row +-- -> m () +-- expandableResizableTableless as expansion encoding@(E.Colonnade v) = do +-- let vlen = coerceDynamic (foldMap (\(E.OneColonnade (Resizable sz _) _) -> coerceDynamic sz :: Dynamic t (Sum Int)) v) :: Dynamic t (Sum Int) +-- totalSizeAttr = fmap (\i -> M.singleton "colspan" (T.pack (show i))) vlen +-- _ <- el "thead" $ el "tr" $ E.headerMonadicGeneral_ encoding (el "th") +-- el "tbody" $ forM_ as $ \a -> do +-- x <- el "tr" $ E.rowMonadicWith [] (++) encoding (fmap (\k -> [k]) . el "td") a +-- let e = leftmost x +-- d <- holdDyn Nothing e +-- elDynAttr "tr" (fmap (maybe (M.singleton "style" "display:none;") (const M.empty)) d) $ do +-- elDynAttr "td" totalSizeAttr (expansion (fmapMaybe id e)) + +data Visible a = Visible !Bool a + +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 + -> Arrangement t + -> Pagination t m + -> Int -- ^ number of records on a page + -> a -- ^ An inhabitant of type @a@ only used for the cells in hidden rows. + -> Colonnade h (Dynamic t a) (c ()) + -> Dynamic t (Vector a) -> m () -expandableResizableTableless as expansion encoding@(E.Colonnade v) = do - let vlen = coerceDynamic (foldMap (\(E.OneColonnade (Resizable sz _) _) -> coerceDynamic sz :: Dynamic t (Sum Int)) v) :: Dynamic t (Sum Int) - totalSizeAttr = fmap (\i -> M.singleton "colspan" (T.pack (show i))) vlen - _ <- el "thead" $ el "tr" $ E.headerMonadicGeneral_ encoding (el "th") - el "tbody" $ forM_ as $ \a -> do - x <- el "tr" $ E.rowMonadicWith [] (++) encoding (fmap (\k -> [k]) . el "td") a - let e = leftmost x - d <- holdDyn Nothing e - elDynAttr "tr" (fmap (maybe (M.singleton "style" "display:none;") (const M.empty)) d) $ do - elDynAttr "td" totalSizeAttr (expansion (fmapMaybe id e)) +paginated (Bureau tableAttrs theadAttrs bodyAttrs trAttrs) arrange (Pagination makePagination) pageSize aDef col vecD = do + let colLifted :: Colonnade h (Dynamic t (Visible a)) (c ()) + colLifted = PF.lmap (fmap (\(Visible _ a) -> a)) col + -- colLifted = E.Colonnade (V.map (\(E.OneColonnade h f) -> E.OneColonnade h (\x -> maybe nothingContents f)) (E.getColonnade col)) + 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 ((`div` pageSize) . V.length) vecD + trAttrsLifted :: Dynamic t (Visible a) -> Dynamic t (Map Text Text) + trAttrsLifted d = do + Visible isVisible a <- d + attrs <- trAttrs a + return (if isVisible then attrs else M.insertWith T.append "style" "display:none;" attrs) + elDynAttr "table" tableAttrs $ case arrange of + ArrangementFooter tfootAttrs tfootTrAttrs tfootThAttrs -> mdo + tableHeader theadAttrs colLifted + let vals = makeVals page + tableBody bodyAttrs trAttrsLifted colLifted vals + page <- elDynAttr "tfoot" tfootAttrs $ do + elDynAttr "tr" tfootTrAttrs $ do + elDynAttr "th" tfootThAttrs $ do + makePagination totalPages + return () + _ -> error "Reflex.Dom.Colonnade: paginated: write this code" + + +tableHeader :: forall t b h c a m. + (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 ()) + -> m () +tableHeader theadAttrsWrap col = case headednessExtractForall of + Nothing -> return () + Just extractForall -> do + let (theadAttrs,trAttrs) = extract theadAttrsWrap + elDynAttr "thead" theadAttrs $ do + elDynAttr "tr" trAttrs $ do + headerMonadicGeneralSizable_ col (extract . sizableCast (Proxy :: Proxy t)) + where + extract :: forall x. b x -> x + extract = E.runExtractForall extractForall + +tableBody :: (DomBuilder t m, PostBuild t m, Foldable f, Monoid e, Cellular t m c, Sizable t b h) + => Dynamic t (M.Map T.Text T.Text) + -> (a -> Dynamic t (M.Map T.Text T.Text)) + -> Colonnade h a (c e) + -> f a + -> m e +tableBody bodyAttrs trAttrs col collection = + elDynAttr "tbody" bodyAttrs $ foldlM (\m a -> do + e <- elDynAttr "tr" (trAttrs a) (rowSizable col a) + return (mappend m e) + ) mempty collection + +headerMonadicGeneralSizable_ :: (Sizable t b h, Cellular t m c) + => Colonnade h a (c ()) + -> (h (c ()) -> c ()) + -> m () +headerMonadicGeneralSizable_ (E.Colonnade v) extract = + V.mapM_ go v + where + go x = do + let h = E.oneColonnadeHead x + c = extract h + attrs = zipDynWith insertSizeAttr (sizableSize h) (cellularAttrs c) + elDynAttr "th" attrs (cellularContents c) + +rowSizable :: (Sizable t b h, Cellular t m c, Monoid e) + => Colonnade h a (c e) + -> a + -> m e +rowSizable (E.Colonnade v) a = V.foldM (\m oc -> do + let c = E.oneColonnadeEncode oc a + e <- elDynAttr "td" (cellularAttrs c) $ do + cellularContents c + return (mappend m e) + ) mempty v + +insertSizeAttr :: Int -> Map Text Text -> Map Text Text +insertSizeAttr i m + | i < 1 = M.insertWith T.append "style" "display:none;" m + | otherwise = M.insert "colspan" (T.pack (show i)) m +