From c752a343821148a9e99a0c89df4e6412ea940246 Mon Sep 17 00:00:00 2001 From: Andrew Martin Date: Wed, 7 Sep 2016 15:53:25 -0400 Subject: [PATCH] add inter-row stuff --- colonnade/colonnade.cabal | 2 +- colonnade/src/Colonnade/Encoding.hs | 34 +++++++++++++++--- colonnade/src/Colonnade/Internal.hs | 6 ++++ .../reflex-dom-colonnade.cabal | 4 +-- .../src/Reflex/Dom/Colonnade.hs | 35 ++++++++++++++++++- 5 files changed, 73 insertions(+), 8 deletions(-) diff --git a/colonnade/colonnade.cabal b/colonnade/colonnade.cabal index b55e754..3cb07b4 100644 --- a/colonnade/colonnade.cabal +++ b/colonnade/colonnade.cabal @@ -1,5 +1,5 @@ name: colonnade -version: 0.4 +version: 0.4.1 synopsis: Generic types and functions for columnar encoding and decoding description: Please see README.md homepage: https://github.com/andrewthad/colonnade#readme diff --git a/colonnade/src/Colonnade/Encoding.hs b/colonnade/src/Colonnade/Encoding.hs index e218974..49b9956 100644 --- a/colonnade/src/Colonnade/Encoding.hs +++ b/colonnade/src/Colonnade/Encoding.hs @@ -2,7 +2,9 @@ module Colonnade.Encoding where import Colonnade.Types import Data.Vector (Vector) +import Data.Foldable import qualified Data.Vector as Vector +import qualified Colonnade.Internal as Internal mapContent :: Functor f => (c1 -> c2) -> Encoding f c1 a -> Encoding f c2 a mapContent f (Encoding v) = Encoding @@ -29,10 +31,25 @@ runRowMonadic :: (Monad m, Monoid b) -> (content -> m b) -> a -> m b -runRowMonadic (Encoding v) g a = fmap (mconcat . Vector.toList) - $ Vector.forM v +runRowMonadic (Encoding v) g a = + -- fmap (mconcat . Vector.toList) + -- $ Vector.forM v + flip Internal.foldMapM v $ \e -> g (oneEncodingEncode e a) +runRowMonadicWith :: (Monad m) + => b + -> (b -> b -> b) + -> Encoding f content a + -> (content -> m b) + -> a + -> m b +runRowMonadicWith bempty bappend (Encoding v) g a = + foldrM (\e br -> do + bl <- g (oneEncodingEncode e a) + return (bappend bl br) + ) bempty v + runHeader :: (c1 -> c2) -> Encoding Headed c1 a -> Vector c2 runHeader g (Encoding v) = Vector.map (g . getHeaded . oneEncodingHead) v @@ -44,14 +61,23 @@ runHeaderMonadic :: (Monad m, Monoid b) runHeaderMonadic (Encoding v) g = fmap (mconcat . Vector.toList) $ Vector.mapM (g . getHeaded . oneEncodingHead) v +runHeaderMonadic_ :: + (Monad m) + => Encoding Headed content a + -> (content -> m b) + -> m () +runHeaderMonadic_ (Encoding v) g = Vector.mapM_ (g . getHeaded . oneEncodingHead) v + fromMaybe :: c -> Encoding f c a -> Encoding f c (Maybe a) fromMaybe c (Encoding v) = Encoding $ flip Vector.map v $ \(OneEncoding h encode) -> OneEncoding h (maybe c encode) columns :: (b -> a -> c) - -> (b -> f c) - -> Vector b + -> (b -> f c) + -> Vector b -> Encoding f c a columns getCell getHeader bs = Encoding $ Vector.map (\b -> OneEncoding (getHeader b) (getCell b)) bs + + diff --git a/colonnade/src/Colonnade/Internal.hs b/colonnade/src/Colonnade/Internal.hs index dd3f36a..e86577b 100644 --- a/colonnade/src/Colonnade/Internal.hs +++ b/colonnade/src/Colonnade/Internal.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DeriveFunctor #-} module Colonnade.Internal where +import Data.Foldable (foldrM) + newtype EitherWrap a b = EitherWrap { getEitherWrap :: Either a b } deriving (Functor) @@ -15,3 +17,7 @@ instance Monoid a => Applicative (EitherWrap a) where mapLeft :: (a -> b) -> Either a c -> Either b c mapLeft _ (Right a) = Right a mapLeft f (Left a) = Left (f a) + +foldMapM :: (Foldable t, Monoid b, Monad m) => (a -> m b) -> t a -> m b +foldMapM f = foldrM (\a b -> fmap (flip mappend b) (f a)) mempty + diff --git a/reflex-dom-colonnade/reflex-dom-colonnade.cabal b/reflex-dom-colonnade/reflex-dom-colonnade.cabal index 5511b7a..3a16c12 100644 --- a/reflex-dom-colonnade/reflex-dom-colonnade.cabal +++ b/reflex-dom-colonnade/reflex-dom-colonnade.cabal @@ -1,5 +1,5 @@ name: reflex-dom-colonnade -version: 0.4 +version: 0.4.1 synopsis: Use colonnade with reflex-dom description: Please see README.md homepage: https://github.com/andrewthad/colonnade#readme @@ -18,7 +18,7 @@ library Reflex.Dom.Colonnade build-depends: base >= 4.7 && < 5 - , colonnade >= 0.3 + , colonnade >= 0.4.1 , contravariant , vector , reflex diff --git a/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs b/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs index dbc5826..ccb1c4e 100644 --- a/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs +++ b/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs @@ -10,13 +10,15 @@ module Reflex.Dom.Colonnade import Colonnade.Types import Control.Monad +import Data.Maybe import Data.Foldable -import Reflex (Dynamic,Event,switchPromptly,never) +import Reflex (Dynamic,Event,switchPromptly,never,leftmost) import Reflex.Dynamic (mapDyn) import Reflex.Dom (MonadWidget) import Reflex.Dom.Widget.Basic import Data.Map (Map) import Data.Semigroup (Semigroup) +import qualified Data.Vector as Vector import qualified Colonnade.Encoding as Encoding import qualified Data.Map as Map @@ -44,6 +46,33 @@ basic tableAttrs as encoding = do el "tbody" $ forM_ as $ \a -> do el "tr" $ Encoding.runRowMonadic encoding (elFromCell "td") a +interRowContent :: (MonadWidget t m, Foldable f) + => String + -> String + -> f a + -> Encoding Headed (Cell m (Event t (Maybe (m ())))) a + -> m () +interRowContent tableClass tdExtraClass as encoding@(Encoding v) = do + let vlen = Vector.length v + elAttr "table" (Map.singleton "class" tableClass) $ do + -- Discarding this result is technically the wrong thing + -- to do, but I cannot imagine why anyone would want to + -- drop down content under the heading. + _ <- theadBuild_ encoding + el "tbody" $ forM_ as $ \a -> do + e' <- el "tr" $ do + e <- Encoding.runRowMonadicWith never const encoding (elFromCell "td") a + let e' = flip fmap e $ \mwidg -> case mwidg of + Nothing -> return () + Just widg -> el "tr" $ do + elAttr "td" ( Map.fromList + [ ("class",tdExtraClass) + , ("colspan",show vlen) + ] + ) widg + return e' + widgetHold (return ()) e' + elFromCell :: MonadWidget t m => String -> Cell m b -> m b elFromCell name (Cell attrs contents) = elAttr name attrs contents @@ -51,6 +80,10 @@ theadBuild :: (MonadWidget t m, Monoid b) => Encoding Headed (Cell m b) a -> m b theadBuild encoding = el "thead" . el "tr" $ Encoding.runHeaderMonadic encoding (elFromCell "th") +theadBuild_ :: (MonadWidget t m) => Encoding Headed (Cell m b) a -> m () +theadBuild_ encoding = el "thead" . el "tr" + $ Encoding.runHeaderMonadic_ encoding (elFromCell "th") + dynamic :: (MonadWidget t m, Foldable f) => Map String String -- ^ Table element attributes -> f (Dynamic t a) -- ^ Dynamic values