mirror of
https://github.com/byteverse/colonnade.git
synced 2026-02-21 18:47:54 +01:00
238 lines
8.6 KiB
Haskell
238 lines
8.6 KiB
Haskell
{-# LANGUAGE DeriveFunctor #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
|
|
module Reflex.Dom.Colonnade
|
|
(
|
|
-- * Types
|
|
Cell(..)
|
|
-- * Table Encoders
|
|
, basic
|
|
, dynamic
|
|
, dynamicEventful
|
|
, expandable
|
|
, listItems
|
|
-- * Cell Functions
|
|
, cell
|
|
, stringCell
|
|
, textCell
|
|
, 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
|
|
|
|
-- | Convenience function for creating a 'Cell' representing
|
|
-- a @td@ or @th@ with no attributes.
|
|
cell :: m b -> Cell m b
|
|
cell = Cell Map.empty
|
|
|
|
stringCell :: MonadWidget t m => String -> Cell m ()
|
|
stringCell = cell . text
|
|
|
|
textCell :: MonadWidget t m => Text -> Cell m ()
|
|
textCell = cell . text . Text.unpack
|
|
|
|
builderCell :: MonadWidget t m => TBuilder.Builder -> Cell m ()
|
|
builderCell = textCell . LText.toStrict . TBuilder.toLazyText
|
|
|
|
-- 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)
|
|
|
|
-- | 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
|
|
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
|
|
-> f a
|
|
-- ^ Rows 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
|
|
elAttr "table" tableAttrs $ do
|
|
theadBuild encoding
|
|
el "tbody" $ forM_ as $ \a -> do
|
|
el "tr" $ Encoding.runRowMonadic encoding (elFromCell "td") a
|
|
|
|
-- | 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
|
|
-> m (Event t e)
|
|
dynamicEventful tableAttrs as encoding@(Encoding v) = do
|
|
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)
|
|
|
|
-- 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
|
|
|
|
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
|
|
|
|
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) | ...
|
|
|