reflex-dom-colonnade 0.4 → 0.4.1
raw patch · 2 files changed
+103/−13 lines, 2 filesdep ~colonnade
Dependency ranges changed: colonnade
Files
- reflex-dom-colonnade.cabal +2/−2
- src/Reflex/Dom/Colonnade.hs +101/−11
reflex-dom-colonnade.cabal view
@@ -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 @@ Reflex.Dom.Colonnade build-depends: base >= 4.7 && < 5- , colonnade >= 0.3+ , colonnade >= 0.4.1 , contravariant , vector , reflex
src/Reflex/Dom/Colonnade.hs view
@@ -1,24 +1,39 @@-module Reflex.Dom.Colonnade where+{-# LANGUAGE DeriveFunctor #-} +module Reflex.Dom.Colonnade+ ( Cell(..)+ , cell+ , basic+ , dynamic+ , dynamicEventful+ ) where+ 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 cell :: m b -> Cell m b cell = Cell Map.empty +-- data NewCell b = NewCell+-- { newCellAttrs :: !(Map String String)+-- , newCellContents :: !b+-- } deriving (Functor)+ data Cell m b = Cell { cellAttrs :: !(Map String String) , cellContents :: !(m b)- }+ } deriving (Functor) basic :: (MonadWidget t m, Foldable f) => Map String String -- ^ Table element attributes@@ -31,6 +46,33 @@ 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 @@ -38,6 +80,10 @@ 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@@ -45,16 +91,16 @@ -> m () dynamic tableAttrs as encoding@(Encoding v) = do elAttr "table" tableAttrs $ do- theadBuild encoding- el "tbody" $ forM_ as $ \a -> 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 ()+ elDynAttr "td" dynAttrs $ dyn dynContent+ return (mappend b1 b2) -dynamicEventful :: (MonadWidget t m, Traversable f, Semigroup e)+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@@ -62,13 +108,57 @@ dynamicEventful 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+ 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 -- TODO: This might actually be wrong. Revisit this. switchPromptly never e- return (mappend b1 (mconcat $ toList $ mconcat $ toList b2))+ return (mappend b1 b2)++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++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++-- 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)++-- data Update f = UpdateName (f Text) | UpdateAge (f Int) | ...