diff --git a/reflex-dom-colonnade/overrides-ghc.nix b/reflex-dom-colonnade/overrides-ghc.nix new file mode 100644 index 0000000..7ffd991 --- /dev/null +++ b/reflex-dom-colonnade/overrides-ghc.nix @@ -0,0 +1,7 @@ +{ reflex-platform, ... }: +let dc = reflex-platform.nixpkgs.haskell.lib.dontCheck; +in reflex-platform.ghc.override { + overrides = self: super: { + colonnade = dc (self.callPackage (reflex-platform.cabal2nixResult ../colonnade) {}); + }; +} diff --git a/reflex-dom-colonnade/reflex-dom-colonnade.cabal b/reflex-dom-colonnade/reflex-dom-colonnade.cabal index deed5c0..38525d7 100644 --- a/reflex-dom-colonnade/reflex-dom-colonnade.cabal +++ b/reflex-dom-colonnade/reflex-dom-colonnade.cabal @@ -18,14 +18,13 @@ library Reflex.Dom.Colonnade build-depends: base >= 4.7 && < 5.0 - , colonnade >= 0.4.6 && < 0.5 + , colonnade >= 1.1 && < 1.2 , contravariant >= 1.2 && < 1.5 , vector >= 0.10 && < 0.12 , text >= 1.0 && < 1.3 - , reflex - , reflex-dom + , reflex == 0.5.* + , reflex-dom == 0.4.* , containers >= 0.5 && < 0.6 - , semigroups >= 0.16 && < 0.19 default-language: Haskell2010 ghc-options: -Wall diff --git a/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs b/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs index f323b82..bc06114 100644 --- a/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs +++ b/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs @@ -1,4 +1,7 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -8,230 +11,226 @@ module Reflex.Dom.Colonnade Cell(..) -- * Table Encoders , basic + , static + , eventful , dynamic , dynamicEventful - , expandable - , listItems + , capped + , cappedEventful -- * Cell Functions , cell + , charCell , stringCell , textCell + , lazyTextCell , builderCell ) where -import Colonnade.Types -import Control.Monad -import Data.Maybe -import Data.Foldable -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 Data.Text (Text) import Data.String (IsString(..)) -import qualified Data.Vector as Vector -import qualified Colonnade.Encoding as Encoding -import qualified Data.Map as Map -import qualified Data.Text as Text -import qualified Data.Text.Lazy as LText -import qualified Data.Text.Lazy.Builder as TBuilder +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Builder as LT +import qualified Data.Map.Strict as M +import Data.Foldable (Foldable(..),for_) +import Data.Traversable (for) +import Data.Semigroup (Semigroup(..)) +import Control.Applicative (liftA2) +import Control.Monad (void) +import Reflex.Dom +import Colonnade (Colonnade,Headed,Fascia,Cornice) +import qualified Colonnade.Encode as E + +data Cell t m b = Cell + { cellAttrs :: !(Dynamic t (M.Map T.Text T.Text)) + , cellContents :: !(m b) + } deriving (Functor) + +elFromCell :: (DomBuilder t m, PostBuild t m) => T.Text -> Cell t m b -> m b +elFromCell e (Cell attr m) = elDynAttr e attr m -- | Convenience function for creating a 'Cell' representing -- a @td@ or @th@ with no attributes. -cell :: m b -> Cell m b -cell = Cell Map.empty +cell :: Reflex t => m b -> Cell t m b +cell = Cell (pure M.empty) -stringCell :: MonadWidget t m => String -> Cell m () -stringCell = cell . text +charCell :: DomBuilder t m => Char -> Cell t m () +charCell = textCell . T.singleton -textCell :: MonadWidget t m => Text -> Cell m () -textCell = cell . text . Text.unpack +stringCell :: DomBuilder t m => String -> Cell t m () +stringCell = cell . text . T.pack -builderCell :: MonadWidget t m => TBuilder.Builder -> Cell m () -builderCell = textCell . LText.toStrict . TBuilder.toLazyText +textCell :: DomBuilder t m => T.Text -> Cell t m () +textCell = cell . text --- data NewCell b = NewCell --- { newCellAttrs :: !(Map String String) --- , newCellContents :: !b --- } deriving (Functor) +lazyTextCell :: DomBuilder t m => LT.Text -> Cell t m () +lazyTextCell = textCell . LT.toStrict -data Cell m b = Cell - { cellAttrs :: !(Map String String) - , cellContents :: !(m b) - } deriving (Functor) +builderCell :: DomBuilder t m => LT.Builder -> Cell t m () +builderCell = textCell . LT.toStrict . LT.toLazyText -- | This instance is requires @UndecidableInstances@ and is kind of -- bad, but @reflex@ already abusing type classes so much that it -- doesn\'t seem too terrible to add this to the mix. -instance (MonadWidget t m, a ~ ()) => IsString (Cell m a) where +instance (DomBuilder t m, a ~ ()) => IsString (Cell t m a) where fromString = stringCell --- | This determines the attributes that are added --- to the individual @li@s by concatenating the header\'s --- attributes with the data\'s attributes. -listItems :: (Foldable f, MonadWidget t m) - => (m () -> m ()) - -- ^ Wrapper for items, often @ul@ - -> (m () -> m () -> m ()) - -- ^ Combines header with data - -> Encoding Headed (Cell m ()) a - -- ^ How to encode data as a row +newtype WrappedApplicative m a = WrappedApplicative + { unWrappedApplicative :: m a } + deriving (Functor,Applicative,Monad) + +instance (Semigroup a, Applicative m) => Semigroup (WrappedApplicative m a) where + (WrappedApplicative m1) <> (WrappedApplicative m2) = WrappedApplicative (liftA2 (<>) m1 m2) + +instance (Monoid a, Applicative m) => Monoid (WrappedApplicative m a) where + mempty = WrappedApplicative (pure mempty) + mappend (WrappedApplicative m1) (WrappedApplicative m2) = WrappedApplicative (liftA2 mappend m1 m2) + +basic :: + (DomBuilder t m, PostBuild t m, Foldable f) + => M.Map T.Text T.Text -- ^ @\@ tag attributes + -> Colonnade Headed a (Cell t m ()) -- ^ Data encoding strategy + -> f a -- ^ Collection of data + -> m () +basic tableAttrs = static tableAttrs Nothing mempty (const mempty) + +body :: (DomBuilder t m, PostBuild t m, Foldable f, Monoid e) + => M.Map T.Text T.Text + -> (a -> M.Map T.Text T.Text) + -> Colonnade p a (Cell t m e) -> f a - -- ^ Rows of data + -> m e +body bodyAttrs trAttrs colonnade collection = + elAttr "tbody" bodyAttrs . unWrappedApplicative . flip foldMap collection $ \a -> + WrappedApplicative . + elAttr "tr" (trAttrs a) . + unWrappedApplicative $ + E.rowMonoidal colonnade (WrappedApplicative . elFromCell "td") a + +static :: + (DomBuilder t m, PostBuild t m, Foldable f, Foldable h) + => 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 @\@ + -> M.Map T.Text T.Text -- ^ @\@ tag attributes + -> (a -> M.Map T.Text T.Text) -- ^ @\@ tag attributes + -> Colonnade h a (Cell t m ()) -- ^ Data encoding strategy + -> f a -- ^ Collection of data -> m () -listItems ulWrap combine enc xs = - forM_ xs $ ulWrap . Encoding.runBothMonadic_ enc - (\(Cell ha hc) (Cell ba bc) -> - -- Consider doing something better than union for - -- combining the two maps. For example, what if they - -- both have a class. - elAttr "li" (Map.union ha ba) (combine hc bc) - ) - --- | A static table -basic :: (MonadWidget t m, Foldable f) - => Map String String -- ^ Table element attributes - -> Encoding Headed (Cell m ()) a -- ^ Encoding of a value into cells - -> f a -- ^ Values - -> m () -basic tableAttrs encoding as = do +static tableAttrs mheadAttrs bodyAttrs trAttrs colonnade collection = elAttr "table" tableAttrs $ do - theadBuild encoding - el "tbody" $ forM_ as $ \a -> do - el "tr" $ Encoding.runRowMonadic encoding (elFromCell "td") a + for_ mheadAttrs $ \(headAttrs,headTrAttrs) -> + elAttr "thead" headAttrs . elAttr "tr" headTrAttrs $ + E.headerMonadicGeneral_ colonnade (elFromCell "th") + body bodyAttrs trAttrs colonnade collection --- | Table with cells that can create expanded content --- between the rows. -expandable :: (MonadWidget t m, Foldable f) - => String -- ^ Table class - -> String -- ^ Class of expanded table rows - -> f a -- ^ Values - -> Encoding Headed (Cell m (Event t (Maybe (m ())))) a - -- ^ Encoding into cells with events that can fire to create additional content under the row - -> m () -expandable 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 - elist <- Encoding.runRowMonadicWith [] (++) encoding (fmap (\a -> [a]) . elFromCell "td") a - let e = leftmost elist - 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' - --- TODO: figure out how to write this. It will need to reset --- the interrow content whenever its corresponding row changes. --- --- dynamicExpandable :: (MonadWidget t m, Foldable f) --- => String --- -> String --- -> f (Dynamic t a) --- -> Encoding Headed (Cell m (Event t (Maybe (m ())))) a --- -> m () - -elFromCell :: MonadWidget t m => String -> Cell m b -> m b -elFromCell name (Cell attrs contents) = elAttr name attrs contents - -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 - -> Encoding Headed (Cell m ()) a -- ^ Encoding of a value into cells - -> m () -dynamic tableAttrs as encoding@(Encoding v) = do - elAttr "table" tableAttrs $ do - b1 <- theadBuild encoding - b2 <- el "tbody" $ forM_ as $ \a -> do - el "tr" $ forM_ v $ \(OneEncoding _ encode) -> do - dynPair <- mapDyn encode a - dynAttrs <- mapDyn cellAttrs dynPair - dynContent <- mapDyn cellContents dynPair - elDynAttr "td" dynAttrs $ dyn dynContent - return (mappend b1 b2) - -dynamicEventful :: (MonadWidget t m, Foldable f, Semigroup e) - => Map String String -- ^ Table element attributes - -> f (Dynamic t a) -- ^ Dynamic values - -> Encoding Headed (Cell m (Event t e)) a -- ^ Encoding of a value into cells +eventful :: + (DomBuilder t m, PostBuild t m, Foldable f, Foldable h, Semigroup 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 @\@ + -> M.Map T.Text T.Text -- ^ @\@ tag attributes + -> (a -> M.Map T.Text T.Text) -- ^ @\@ tag attributes + -> Colonnade h a (Cell t m (Event t e)) -- ^ Data encoding strategy + -> f a -- ^ Collection of data -> m (Event t e) -dynamicEventful tableAttrs as encoding@(Encoding v) = do +eventful tableAttrs mheadAttrs bodyAttrs trAttrs colonnade collection = elAttr "table" tableAttrs $ do - b1 <- theadBuild encoding - b2 <- el "tbody" $ flip foldlMapM as $ \a -> do - el "tr" $ flip foldlMapM v $ \(OneEncoding _ encode) -> do - dynPair <- mapDyn encode a - dynAttrs <- mapDyn cellAttrs dynPair - dynContent <- mapDyn cellContents dynPair - e <- elDynAttr "td" dynAttrs $ dyn dynContent - -- TODO: This might actually be wrong. Revisit this. - switchPromptly never e - return (mappend b1 b2) + eHead <- for mheadAttrs $ \(headAttrs,headTrAttrs) -> + elAttr "thead" headAttrs . elAttr "tr" headTrAttrs $ + E.headerMonadicGeneral colonnade (elFromCell "th") + eBody <- body bodyAttrs trAttrs colonnade collection + return (maybe never id eHead <> eBody) --- foldMapM :: (Foldable t, Monoid b, Monad m) => (a -> m b) -> t a -> m b --- foldMapM f = foldlM (\b a -> fmap (flip mappend b) (f a)) mempty +dynamicBody :: (DomBuilder t m, PostBuild t m, Foldable f, Semigroup e, Monoid e) + => Dynamic t (M.Map T.Text T.Text) + -> (a -> M.Map T.Text T.Text) + -> Colonnade p a (Cell t m e) + -> f (Dynamic t a) + -> m (Event t e) +dynamicBody bodyAttrs trAttrs colonnade collection = + elDynAttr "tbody" bodyAttrs . unWrappedApplicative . flip foldMap collection $ \aDyn -> + WrappedApplicative . + elDynAttr "tr" (fmap trAttrs aDyn) $ + dyn (fmap (unWrappedApplicative . E.rowMonoidal colonnade (WrappedApplicative . elFromCell "td")) aDyn) -foldlMapM :: (Foldable t, Monoid b, Monad m) => (a -> m b) -> t a -> m b -foldlMapM f = foldlM (\b a -> fmap (mappend b) (f a)) mempty +dynamic :: + (DomBuilder t m, PostBuild t m, Foldable f, Foldable h) + => 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 @\@ + -> Dynamic t (M.Map T.Text T.Text) -- ^ @\@ tag attributes + -> (a -> M.Map T.Text T.Text) -- ^ @\@ tag attributes + -> Colonnade h a (Cell t m ()) -- ^ Data encoding strategy + -> f (Dynamic t a) -- ^ Collection of data + -> m () +dynamic tableAttrs mheadAttrs bodyAttrs trAttrs colonnade collection = + elDynAttr "table" tableAttrs $ do + for_ mheadAttrs $ \(headAttrs,headTrAttrs) -> + elDynAttr "thead" headAttrs . elDynAttr "tr" headTrAttrs $ + E.headerMonadicGeneral_ colonnade (elFromCell "th") + void (dynamicBody bodyAttrs trAttrs colonnade collection) -foldAlternativeM :: (Foldable t, Monoid b, Monad m) => (a -> m b) -> t a -> m b -foldAlternativeM f = foldrM (\a b -> fmap (flip mappend b) (f a)) mempty +dynamicEventful :: + (DomBuilder t m, PostBuild t m, MonadHold t m, Foldable f, Foldable h, Semigroup 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 @\@ + -> Dynamic t (M.Map T.Text T.Text) -- ^ @\@ tag attributes + -> (a -> M.Map T.Text T.Text) -- ^ @\@ tag attributes + -> Colonnade h a (Cell t m (Event t e)) -- ^ Data encoding strategy + -> f (Dynamic t a) -- ^ Collection of data + -> m (Event t e) +dynamicEventful tableAttrs mheadAttrs bodyAttrs trAttrs colonnade collection = + elDynAttr "table" tableAttrs $ do + eHead <- for mheadAttrs $ \(headAttrs,headTrAttrs) -> + elDynAttr "thead" headAttrs . elDynAttr "tr" headTrAttrs $ + E.headerMonadicGeneral colonnade (elFromCell "th") + eeBody <- dynamicBody bodyAttrs trAttrs colonnade collection + eBody <- hold never eeBody + return (maybe never id eHead <> switch eBody) --- dynamicEventfulWith :: (MonadWidget t m, Foldable f, Semigroup e, Monoid b) --- => (e -> b) --- -> Map String String -- ^ Table element attributes --- -> f (Dynamic t a) -- ^ Dynamic values --- -> Encoding Headed (Cell m (Event t e)) a -- ^ Encoding of a value into cells --- -> m (Event t e) --- dynamicEventfulWith f tableAttrs as encoding@(Encoding v) = do --- elAttr "table" tableAttrs $ do --- b1 <- theadBuild encoding --- b2 <- el "tbody" $ flip foldMapM as $ \a -> do --- el "tr" $ flip foldMapM v $ \(OneEncoding _ encode) -> do --- dynPair <- mapDyn encode a --- dynAttrs <- mapDyn cellAttrs dynPair --- dynContent <- mapDyn cellContents dynPair --- e <- elDynAttr "td" dynAttrs $ dyn dynContent --- flattenedEvent <- switchPromptly never e --- return (f flattenedEvent) --- return (mappend b1 b2) --- --- dynamicEventfulMany :: (MonadWidget t m, Foldable f, Alternative g) --- => Map String String -- ^ Table element attributes --- -> f (Dynamic t a) -- ^ Dynamic values --- -> Encoding Headed (NewCell (g (Compose m (Event t)))) a -- ^ Encoding of a value into cells --- -> m (g (Event t e)) --- dynamicEventfulMany tableAttrs as encoding@(Encoding v) = do --- elAttr "table" tableAttrs $ do --- -- b1 <- theadBuild encoding --- b2 <- el "tbody" $ flip foldMapM as $ \a -> do --- el "tr" $ flip foldMapM v $ \(OneEncoding _ encode) -> do --- dynPair <- mapDyn encode a --- dynAttrs <- mapDyn cellAttrs dynPair --- dynContent <- mapDyn cellContents dynPair --- e <- elDynAttr "td" dynAttrs $ dyn dynContent --- switchPromptly never e --- return (mappend b1 b2) +encodeCorniceHead :: + (DomBuilder t m, PostBuild t m, Monoid e) + => Dynamic t (M.Map T.Text T.Text) + -> Fascia p (Dynamic t (M.Map T.Text T.Text)) + -> E.AnnotatedCornice p a (Cell t m e) + -> m e +encodeCorniceHead headAttrs fascia annCornice = + elDynAttr "thead" headAttrs (unWrappedApplicative thead) + where thead = E.headersMonoidal (Just (fascia, addAttr)) [(th,id)] annCornice + th size (Cell attrs contents) = WrappedApplicative (elDynAttr "th" (fmap addColspan attrs) contents) + where addColspan = M.insert "colspan" (T.pack (show size)) + addAttr attrs = WrappedApplicative . elDynAttr "tr" attrs . unWrappedApplicative --- data Update f = UpdateName (f Text) | UpdateAge (f Int) | ... +capped :: + (DomBuilder t m, PostBuild t m, MonadHold t m, Foldable f) + => Dynamic t (M.Map T.Text T.Text) -- ^ @\@ tag attributes + -> Dynamic t (M.Map T.Text T.Text) -- ^ @\@ tag attributes + -> Dynamic t (M.Map T.Text T.Text) -- ^ @\@ tag attributes + -> (a -> M.Map T.Text T.Text) -- ^ @\@ tag attributes + -> Fascia p (Dynamic t (M.Map T.Text T.Text)) -- ^ Attributes for @\@ elements in the @\@ + -> Cornice p a (Cell t m ()) -- ^ Data encoding strategy + -> f (Dynamic t a) -- ^ Collection of data + -> m () +capped tableAttrs headAttrs bodyAttrs trAttrs fascia cornice collection = + elDynAttr "table" tableAttrs $ do + encodeCorniceHead headAttrs fascia (E.annotate cornice) + void (dynamicBody bodyAttrs trAttrs (E.discard cornice) collection) +cappedEventful :: + forall t m f e p a. + (DomBuilder t m, PostBuild t m, MonadHold t m, Foldable f, Semigroup e) + => Dynamic t (M.Map T.Text T.Text) -- ^ @\@ tag attributes + -> Dynamic t (M.Map T.Text T.Text) -- ^ @\@ tag attributes + -> Dynamic t (M.Map T.Text T.Text) -- ^ @\@ tag attributes + -> (a -> M.Map T.Text T.Text) -- ^ @\@ tag attributes + -> Fascia p (Dynamic t (M.Map T.Text T.Text)) -- ^ Attributes for @\@ elements in the @\@ + -> Cornice p a (Cell t m (Event t e)) -- ^ Data encoding strategy + -> f (Dynamic t a) -- ^ Collection of data + -> m (Event t e) +cappedEventful tableAttrs headAttrs bodyAttrs trAttrs fascia cornice collection = + elDynAttr "table" tableAttrs $ do + eHead <- encodeCorniceHead headAttrs fascia (E.annotate cornice) + eeBody <- dynamicBody bodyAttrs trAttrs (E.discard cornice) collection + eBody <- hold never eeBody + return (eHead <> switch eBody)