haskell/colonnade
1
0
Fork 1
mirror of https://github.com/byteverse/colonnade.git synced 2026-04-24 00:47:44 +02:00
Code Issues Actions Packages Projects Releases Wiki Activity

make annotated cornice more flexible, allow reflex-dom tables whose columns can be hidden

Browse Source
This commit is contained in:
Andrew Martin 2017-09-15 14:43:04 -04:00
parent a0b4b1aa7e
commit 01a75dc318
5 changed files with 204 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
blaze-colonnade/src/Text/Blaze/Colonnade.hs
View File

@ -341,7 +341,7 @@ encodeTable mtheadAttrs tbodyAttrs trAttrs wrapContent tableAttrs colonnade xs =
encodeCappedCellTable :: Foldable f encodeCappedCellTable :: Foldable f
=> Attribute -- ^ Attributes of @\<table\>@ element => Attribute -- ^ Attributes of @\<table\>@ element
-> Fascia p Attribute -- ^ Attributes for @\<tr\>@ elements in the @\<thead\>@ -> Fascia p Attribute -- ^ Attributes for @\<tr\>@ elements in the @\<thead\>@
-> Cornice p a Cell -> Cornice Headed p a Cell
-> f a -- ^ Collection of data -> f a -- ^ Collection of data
-> Html -> Html
encodeCappedCellTable = encodeCappedTable mempty mempty (const mempty) htmlFromCell encodeCappedCellTable = encodeCappedTable mempty mempty (const mempty) htmlFromCell
@ -356,7 +356,7 @@ encodeCappedTable :: Foldable f
-> ((Html -> Html) -> c -> Html) -- ^ Wrap content and convert to 'Html' -> ((Html -> Html) -> c -> Html) -- ^ Wrap content and convert to 'Html'
-> Attribute -- ^ Attributes of @\<table\>@ element -> Attribute -- ^ Attributes of @\<table\>@ element
-> Fascia p Attribute -- ^ Attributes for @\<tr\>@ elements in the @\<thead\>@ -> Fascia p Attribute -- ^ Attributes for @\<tr\>@ elements in the @\<thead\>@
-> Cornice p a c -> Cornice Headed p a c
-> f a -- ^ Collection of data -> f a -- ^ Collection of data
-> Html -> Html
encodeCappedTable theadAttrs tbodyAttrs trAttrs wrapContent tableAttrs fascia cornice xs = do encodeCappedTable theadAttrs tbodyAttrs trAttrs wrapContent tableAttrs fascia cornice xs = do
@ -366,7 +366,12 @@ encodeCappedTable theadAttrs tbodyAttrs trAttrs wrapContent tableAttrs fascia co
H.thead ! theadAttrs $ do H.thead ! theadAttrs $ do
Encode.headersMonoidal Encode.headersMonoidal
(Just (fascia, \attrs theHtml -> H.tr ! attrs $ theHtml)) (Just (fascia, \attrs theHtml -> H.tr ! attrs $ theHtml))
[(\sz c -> wrapContent H.th c ! HA.colspan (H.toValue (show sz)),id)] [ ( \msz c -> case msz of
Just sz -> wrapContent H.th c ! HA.colspan (H.toValue (show sz))
Nothing -> mempty
, id
)
]
annCornice annCornice
-- H.tr ! trAttrs $ do -- H.tr ! trAttrs $ do
-- Encode.headerMonoidalGeneral colonnade (wrapContent H.th) -- Encode.headerMonoidalGeneral colonnade (wrapContent H.th)

62
colonnade/src/Colonnade.hs
View File

@ -272,7 +272,7 @@ replaceWhen = modifyWhen . const
-- --
-- >>> let cor = mconcat [cap "Person" colPersonFst, cap "House" colHouseSnd] -- >>> let cor = mconcat [cap "Person" colPersonFst, cap "House" colHouseSnd]
-- >>> :t cor -- >>> :t cor
-- cor :: Cornice ('Cap 'Base) (Person, House) [Char] -- cor :: Cornice Headed ('Cap 'Base) (Person, House) [Char]
-- >>> putStr (asciiCapped cor personHomePairs) -- >>> putStr (asciiCapped cor personHomePairs)
-- +-------------+-----------------+ -- +-------------+-----------------+
-- | Person | House | -- | Person | House |
@ -284,7 +284,7 @@ replaceWhen = modifyWhen . const
-- | Sonia | 12 | Green | $150000 | -- | Sonia | 12 | Green | $150000 |
-- +-------+-----+-------+---------+ -- +-------+-----+-------+---------+
-- --
cap :: c -> Colonnade Headed a c -> Cornice (Cap Base) a c cap :: c -> Colonnade h a c -> Cornice h (Cap Base) a c
cap h = E.CorniceCap . Vector.singleton . E.OneCornice h . E.CorniceBase cap h = E.CorniceCap . Vector.singleton . E.OneCornice h . E.CorniceBase
-- | Add another cap to a cornice. There is no limit to how many times -- | Add another cap to a cornice. There is no limit to how many times
@ -319,11 +319,11 @@ cap h = E.CorniceCap . Vector.singleton . E.OneCornice h . E.CorniceBase
-- | Weekday | $8 | $8 | $8 | $6 | $7 | $8 | $8 | $8 | $6 | $7 | -- | Weekday | $8 | $8 | $8 | $6 | $7 | $8 | $8 | $8 | $6 | $7 |
-- | Weekend | $9 | $9 | $9 | $7 | $8 | $9 | $9 | $9 | $7 | $8 | -- | Weekend | $9 | $9 | $9 | $7 | $8 | $9 | $9 | $9 | $7 | $8 |
-- +---------+----+----+----+------+-------+----+----+----+------+-------+ -- +---------+----+----+----+------+-------+----+----+----+------+-------+
recap :: c -> Cornice p a c -> Cornice (Cap p) a c recap :: c -> Cornice h p a c -> Cornice h (Cap p) a c
recap h cor = E.CorniceCap (Vector.singleton (E.OneCornice h cor)) recap h cor = E.CorniceCap (Vector.singleton (E.OneCornice h cor))
asciiCapped :: Foldable f asciiCapped :: Foldable f
=> Cornice p a String -- ^ columnar encoding => Cornice Headed p a String -- ^ columnar encoding
-> f a -- ^ rows -> f a -- ^ rows
-> String -> String
asciiCapped cor xs = asciiCapped cor xs =
@ -332,8 +332,16 @@ asciiCapped cor xs =
sizedCol = E.uncapAnnotated annCor sizedCol = E.uncapAnnotated annCor
in E.headersMonoidal in E.headersMonoidal
Nothing Nothing
[ (\sz _ -> hyphens (sz + 2) ++ "+", \s -> "+" ++ s ++ "\n") [ ( \msz _ -> case msz of
, (\sz c -> " " ++ rightPad sz ' ' c ++ " |", \s -> "|" ++ s ++ "\n") Just sz -> "+" ++ hyphens (sz + 2)
Nothing -> ""
, \s -> s ++ "+\n"
)
, ( \msz c -> case msz of
Just sz -> "| " ++ rightPad sz ' ' c ++ " "
Nothing -> ""
, \s -> s ++ "|\n"
)
] annCor ++ asciiBody sizedCol xs ] annCor ++ asciiBody sizedCol xs
@ -349,41 +357,49 @@ ascii :: Foldable f
ascii col xs = ascii col xs =
let sizedCol = E.sizeColumns List.length xs col let sizedCol = E.sizeColumns List.length xs col
divider = concat divider = concat
[ "+" [ E.headerMonoidalFull sizedCol
, E.headerMonoidalFull sizedCol (\(E.Sized msz _) -> case msz of
(\(E.Sized sz _) -> hyphens (sz + 2) ++ "+") Just sz -> "+" ++ hyphens (sz + 2)
, "\n" Nothing -> ""
)
, "+\n"
] ]
in List.concat in List.concat
[ divider [ divider
, concat , concat
[ "|" [ E.headerMonoidalFull sizedCol
, E.headerMonoidalFull sizedCol (\(E.Sized msz (Headed h)) -> case msz of
(\(E.Sized s (Headed h)) -> " " ++ rightPad s ' ' h ++ " |") Just sz -> "| " ++ rightPad sz ' ' h ++ " "
, "\n" Nothing -> ""
)
, "|\n"
] ]
, asciiBody sizedCol xs , asciiBody sizedCol xs
] ]
asciiBody :: Foldable f asciiBody :: Foldable f
=> Colonnade (E.Sized Headed) a String => Colonnade (E.Sized (Maybe Int) Headed) a String
-> f a -> f a
-> String -> String
asciiBody sizedCol xs = asciiBody sizedCol xs =
let divider = concat let divider = concat
[ "+" [ E.headerMonoidalFull sizedCol
, E.headerMonoidalFull sizedCol (\(E.Sized msz _) -> case msz of
(\(E.Sized sz _) -> hyphens (sz + 2) ++ "+") Just sz -> "+" ++ hyphens (sz + 2)
, "\n" Nothing -> ""
)
, "+\n"
] ]
rowContents = foldMap rowContents = foldMap
(\x -> concat (\x -> concat
[ "|" [ E.rowMonoidalHeader
, E.rowMonoidalHeader
sizedCol sizedCol
(\(E.Sized sz _) c -> " " ++ rightPad sz ' ' c ++ " |") (\(E.Sized msz _) c -> case msz of
Nothing -> ""
Just sz -> "| " ++ rightPad sz ' ' c ++ " "
)
x x
, "\n" , "|\n"
] ]
) xs ) xs
in List.concat in List.concat

110
colonnade/src/Colonnade/Encode.hs
View File

@ -175,7 +175,7 @@ sizeColumns :: (Foldable f, Foldable h)
=> (c -> Int) -- ^ Get size from content => (c -> Int) -- ^ Get size from content
-> f a -> f a
-> Colonnade h a c -> Colonnade h a c
-> Colonnade (Sized h) a c -> Colonnade (Sized (Maybe Int) h) a c
sizeColumns toSize rows colonnade = runST $ do sizeColumns toSize rows colonnade = runST $ do
mcol <- newMutableSizedColonnade colonnade mcol <- newMutableSizedColonnade colonnade
headerUpdateSize toSize mcol headerUpdateSize toSize mcol
@ -187,14 +187,14 @@ newMutableSizedColonnade (Colonnade v) = do
mv <- MVU.replicate (V.length v) 0 mv <- MVU.replicate (V.length v) 0
return (MutableSizedColonnade v mv) return (MutableSizedColonnade v mv)
freezeMutableSizedColonnade :: MutableSizedColonnade s h a c -> ST s (Colonnade (Sized h) a c) freezeMutableSizedColonnade :: MutableSizedColonnade s h a c -> ST s (Colonnade (Sized (Maybe Int) h) a c)
freezeMutableSizedColonnade (MutableSizedColonnade v mv) = freezeMutableSizedColonnade (MutableSizedColonnade v mv) =
if MVU.length mv /= V.length v if MVU.length mv /= V.length v
then error "rowMonoidalSize: vector sizes mismatched" then error "rowMonoidalSize: vector sizes mismatched"
else do else do
sizeVec <- VU.freeze mv sizeVec <- VU.freeze mv
return $ Colonnade return $ Colonnade
$ V.map (\(OneColonnade h enc,sz) -> OneColonnade (Sized sz h) enc) $ V.map (\(OneColonnade h enc,sz) -> OneColonnade (Sized (Just sz) h) enc)
$ V.zip v (GV.convert sizeVec) $ V.zip v (GV.convert sizeVec)
rowMonadicWith :: rowMonadicWith ::
@ -266,37 +266,41 @@ headerMonadic_ (Colonnade v) g = Vector.mapM_ (g . getHeaded . oneColonnadeHead)
foldlMapM :: (Foldable t, Monoid b, Monad m) => (a -> m b) -> t a -> m b 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 foldlMapM f = foldlM (\b a -> fmap (mappend b) (f a)) mempty
discard :: Cornice p a c -> Colonnade Headed a c discard :: Cornice h p a c -> Colonnade h a c
discard = go where discard = go where
go :: forall p a c. Cornice p a c -> Colonnade Headed a c go :: forall h p a c. Cornice h p a c -> Colonnade h a c
go (CorniceBase c) = c go (CorniceBase c) = c
go (CorniceCap children) = Colonnade (getColonnade . go . oneCorniceBody =<< children) go (CorniceCap children) = Colonnade (getColonnade . go . oneCorniceBody =<< children)
endow :: forall p a c. (c -> c -> c) -> Cornice p a c -> Colonnade Headed a c endow :: forall p a c. (c -> c -> c) -> Cornice Headed p a c -> Colonnade Headed a c
endow f x = case x of endow f x = case x of
CorniceBase colonnade -> colonnade CorniceBase colonnade -> colonnade
CorniceCap v -> Colonnade (V.concatMap (\(OneCornice h b) -> go h b) v) CorniceCap v -> Colonnade (V.concatMap (\(OneCornice h b) -> go h b) v)
where where
go :: forall p'. c -> Cornice p' a c -> Vector (OneColonnade Headed a c) go :: forall p'. c -> Cornice Headed p' a c -> Vector (OneColonnade Headed a c)
go c (CorniceBase (Colonnade v)) = V.map (mapOneColonnadeHeader (f c)) v go c (CorniceBase (Colonnade v)) = V.map (mapOneColonnadeHeader (f c)) v
go c (CorniceCap v) = V.concatMap (\(OneCornice h b) -> go (f c h) b) v go c (CorniceCap v) = V.concatMap (\(OneCornice h b) -> go (f c h) b) v
uncapAnnotated :: forall p a c. AnnotatedCornice p a c -> Colonnade (Sized Headed) a c uncapAnnotated :: forall sz p a c.
AnnotatedCornice sz p a c
-> Colonnade (Sized sz Headed) a c
uncapAnnotated x = case x of uncapAnnotated x = case x of
AnnotatedCorniceBase _ colonnade -> colonnade AnnotatedCorniceBase _ colonnade -> colonnade
AnnotatedCorniceCap _ v -> Colonnade (V.concatMap (\(OneCornice _ b) -> go b) v) AnnotatedCorniceCap _ v -> Colonnade (V.concatMap (\(OneCornice _ b) -> go b) v)
where where
go :: forall p'. AnnotatedCornice p' a c -> Vector (OneColonnade (Sized Headed) a c) go :: forall p'.
AnnotatedCornice sz p' a c
-> Vector (OneColonnade (Sized sz Headed) a c)
go (AnnotatedCorniceBase _ (Colonnade v)) = v go (AnnotatedCorniceBase _ (Colonnade v)) = v
go (AnnotatedCorniceCap _ v) = V.concatMap (\(OneCornice _ b) -> go b) v go (AnnotatedCorniceCap _ v) = V.concatMap (\(OneCornice _ b) -> go b) v
annotate :: Cornice p a c -> AnnotatedCornice p a c annotate :: Cornice Headed p a c -> AnnotatedCornice (Maybe Int) p a c
annotate = go where annotate = go where
go :: forall p a c. Cornice p a c -> AnnotatedCornice p a c go :: forall p a c. Cornice Headed p a c -> AnnotatedCornice (Maybe Int) p a c
go (CorniceBase c) = let len = V.length (getColonnade c) in go (CorniceBase c) = let len = V.length (getColonnade c) in
AnnotatedCorniceBase AnnotatedCorniceBase
(if len > 0 then (Just len) else Nothing) (if len > 0 then (Just len) else Nothing)
(mapHeadedness (Sized 1) c) (mapHeadedness (Sized (Just 1)) c)
go (CorniceCap children) = go (CorniceCap children) =
let annChildren = fmap (mapOneCorniceBody go) children let annChildren = fmap (mapOneCorniceBody go) children
in AnnotatedCorniceCap in AnnotatedCorniceCap
@ -324,8 +328,8 @@ annotateFinely :: Foldable f
-> (Int -> Int) -- ^ finalize -> (Int -> Int) -- ^ finalize
-> (c -> Int) -- ^ Get size from content -> (c -> Int) -- ^ Get size from content
-> f a -> f a
-> Cornice p a c -> Cornice Headed p a c
-> AnnotatedCornice p a c -> AnnotatedCornice (Maybe Int) p a c
annotateFinely g finish toSize xs cornice = runST $ do annotateFinely g finish toSize xs cornice = runST $ do
m <- newMutableSizedCornice cornice m <- newMutableSizedCornice cornice
sizeColonnades toSize xs m sizeColonnades toSize xs m
@ -352,16 +356,18 @@ freezeMutableSizedCornice :: forall s p a c.
(Int -> Int -> Int) -- ^ fold function (Int -> Int -> Int) -- ^ fold function
-> (Int -> Int) -- ^ finalize -> (Int -> Int) -- ^ finalize
-> MutableSizedCornice s p a c -> MutableSizedCornice s p a c
-> ST s (AnnotatedCornice p a c) -> ST s (AnnotatedCornice (Maybe Int) p a c)
freezeMutableSizedCornice step finish = go freezeMutableSizedCornice step finish = go
where where
go :: forall p' a' c'. MutableSizedCornice s p' a' c' -> ST s (AnnotatedCornice p' a' c') go :: forall p' a' c'.
MutableSizedCornice s p' a' c'
-> ST s (AnnotatedCornice (Maybe Int) p' a' c')
go (MutableSizedCorniceBase msc) = do go (MutableSizedCorniceBase msc) = do
szCol <- freezeMutableSizedColonnade msc szCol <- freezeMutableSizedColonnade msc
let sz = let sz =
( mapJustInt finish ( mapJustInt finish
. V.foldl' (combineJustInt step) Nothing . V.foldl' (combineJustInt step) Nothing
. V.map (Just . sizedSize . oneColonnadeHead) . V.map (sizedSize . oneColonnadeHead)
) (getColonnade szCol) ) (getColonnade szCol)
return (AnnotatedCorniceBase sz szCol) return (AnnotatedCorniceBase sz szCol)
go (MutableSizedCorniceCap v1) = do go (MutableSizedCorniceCap v1) = do
@ -374,10 +380,10 @@ freezeMutableSizedCornice step finish = go
return $ AnnotatedCorniceCap sz v2 return $ AnnotatedCorniceCap sz v2
newMutableSizedCornice :: forall s p a c. newMutableSizedCornice :: forall s p a c.
Cornice p a c Cornice Headed p a c
-> ST s (MutableSizedCornice s p a c) -> ST s (MutableSizedCornice s p a c)
newMutableSizedCornice = go where newMutableSizedCornice = go where
go :: forall p'. Cornice p' a c -> ST s (MutableSizedCornice s p' a c) go :: forall p'. Cornice Headed p' a c -> ST s (MutableSizedCornice s p' a c)
go (CorniceBase c) = fmap MutableSizedCorniceBase (newMutableSizedColonnade c) go (CorniceBase c) = fmap MutableSizedCorniceBase (newMutableSizedColonnade c)
go (CorniceCap v) = fmap MutableSizedCorniceCap (V.mapM (traverseOneCorniceBody go) v) go (CorniceCap v) = fmap MutableSizedCorniceCap (V.mapM (traverseOneCorniceBody go) v)
@ -390,7 +396,7 @@ mapHeadedness f (Colonnade v) =
-- | This is an O(1) operation, sort of -- | This is an O(1) operation, sort of
size :: AnnotatedCornice p a c -> Maybe Int size :: AnnotatedCornice sz p a c -> sz
size x = case x of size x = case x of
AnnotatedCorniceBase m _ -> m AnnotatedCorniceBase m _ -> m
AnnotatedCorniceCap sz _ -> sz AnnotatedCorniceCap sz _ -> sz
@ -401,15 +407,15 @@ mapOneCorniceBody f (OneCornice h b) = OneCornice h (f b)
mapOneColonnadeHeader :: Functor h => (c -> c) -> OneColonnade h a c -> OneColonnade h a c mapOneColonnadeHeader :: Functor h => (c -> c) -> OneColonnade h a c -> OneColonnade h a c
mapOneColonnadeHeader f (OneColonnade h b) = OneColonnade (fmap f h) b mapOneColonnadeHeader f (OneColonnade h b) = OneColonnade (fmap f h) b
headersMonoidal :: forall r m c p a. headersMonoidal :: forall sz r m c p a.
Monoid m Monoid m
=> Maybe (Fascia p r, r -> m -> m) -- ^ Apply the Fascia header row content => Maybe (Fascia p r, r -> m -> m) -- ^ Apply the Fascia header row content
-> [(Int -> c -> m, m -> m)] -- ^ Build content from cell content and size -> [(sz -> c -> m, m -> m)] -- ^ Build content from cell content and size
-> AnnotatedCornice p a c -> AnnotatedCornice sz p a c
-> m -> m
headersMonoidal wrapRow fromContentList = go wrapRow headersMonoidal wrapRow fromContentList = go wrapRow
where where
go :: forall p'. Maybe (Fascia p' r, r -> m -> m) -> AnnotatedCornice p' a c -> m go :: forall p'. Maybe (Fascia p' r, r -> m -> m) -> AnnotatedCornice sz p' a c -> m
go ef (AnnotatedCorniceBase _ (Colonnade v)) = go ef (AnnotatedCorniceBase _ (Colonnade v)) =
let g :: m -> m let g :: m -> m
g m = case ef of g m = case ef of
@ -424,10 +430,7 @@ headersMonoidal wrapRow fromContentList = go wrapRow
Nothing -> m Nothing -> m
Just (FasciaCap r _, f) -> f r m Just (FasciaCap r _, f) -> f r m
in g (foldMap (\(fromContent,wrap) -> wrap (foldMap (\(OneCornice h b) -> in g (foldMap (\(fromContent,wrap) -> wrap (foldMap (\(OneCornice h b) ->
(case size b of (fromContent (size b) h)) v)) fromContentList)
Nothing -> mempty
Just sz -> fromContent sz h)
) v)) fromContentList)
<> case ef of <> case ef of
Nothing -> case flattenAnnotated v of Nothing -> case flattenAnnotated v of
Nothing -> mempty Nothing -> mempty
@ -436,23 +439,33 @@ headersMonoidal wrapRow fromContentList = go wrapRow
Nothing -> mempty Nothing -> mempty
Just annCoreNext -> go (Just (fn,f)) annCoreNext Just annCoreNext -> go (Just (fn,f)) annCoreNext
flattenAnnotated :: Vector (OneCornice AnnotatedCornice p a c) -> Maybe (AnnotatedCornice p a c) flattenAnnotated ::
Vector (OneCornice (AnnotatedCornice sz) p a c)
-> Maybe (AnnotatedCornice sz p a c)
flattenAnnotated v = case v V.!? 0 of flattenAnnotated v = case v V.!? 0 of
Nothing -> Nothing Nothing -> Nothing
Just (OneCornice _ x) -> Just $ case x of Just (OneCornice _ x) -> Just $ case x of
AnnotatedCorniceBase m _ -> flattenAnnotatedBase m v AnnotatedCorniceBase m _ -> flattenAnnotatedBase m v
AnnotatedCorniceCap m _ -> flattenAnnotatedCap m v AnnotatedCorniceCap m _ -> flattenAnnotatedCap m v
flattenAnnotatedBase :: Maybe Int -> Vector (OneCornice AnnotatedCornice Base a c) -> AnnotatedCornice Base a c flattenAnnotatedBase ::
sz
-> Vector (OneCornice (AnnotatedCornice sz) Base a c)
-> AnnotatedCornice sz Base a c
flattenAnnotatedBase msz = AnnotatedCorniceBase msz flattenAnnotatedBase msz = AnnotatedCorniceBase msz
. Colonnade . Colonnade
. V.concatMap . V.concatMap
(\(OneCornice _ (AnnotatedCorniceBase _ (Colonnade v))) -> v) (\(OneCornice _ (AnnotatedCorniceBase _ (Colonnade v))) -> v)
flattenAnnotatedCap :: Maybe Int -> Vector (OneCornice AnnotatedCornice (Cap p) a c) -> AnnotatedCornice (Cap p) a c flattenAnnotatedCap ::
sz
-> Vector (OneCornice (AnnotatedCornice sz) (Cap p) a c)
-> AnnotatedCornice sz (Cap p) a c
flattenAnnotatedCap m = AnnotatedCorniceCap m . V.concatMap getTheVector flattenAnnotatedCap m = AnnotatedCorniceCap m . V.concatMap getTheVector
getTheVector :: OneCornice AnnotatedCornice (Cap p) a c -> Vector (OneCornice AnnotatedCornice p a c) getTheVector ::
OneCornice (AnnotatedCornice sz) (Cap p) a c
-> Vector (OneCornice (AnnotatedCornice sz) p a c)
getTheVector (OneCornice _ (AnnotatedCorniceCap _ v)) = v getTheVector (OneCornice _ (AnnotatedCorniceCap _ v)) = v
data MutableSizedCornice s (p :: Pillar) a c where data MutableSizedCornice s (p :: Pillar) a c where
@ -492,8 +505,8 @@ newtype Headed a = Headed { getHeaded :: a }
data Headless a = Headless data Headless a = Headless
deriving (Eq,Ord,Functor,Show,Read,Foldable) deriving (Eq,Ord,Functor,Show,Read,Foldable)
data Sized f a = Sized data Sized sz f a = Sized
{ sizedSize :: {-# UNPACK #-} !Int { sizedSize :: !sz
, sizedContent :: !(f a) , sizedContent :: !(f a)
} deriving (Functor, Foldable) } deriving (Functor, Foldable)
@ -554,7 +567,7 @@ instance Semigroup (Colonnade h a c) where
data Pillar = Cap !Pillar | Base data Pillar = Cap !Pillar | Base
class ToEmptyCornice (p :: Pillar) where class ToEmptyCornice (p :: Pillar) where
toEmptyCornice :: Cornice p a c toEmptyCornice :: Cornice h p a c
instance ToEmptyCornice Base where instance ToEmptyCornice Base where
toEmptyCornice = CorniceBase mempty toEmptyCornice = CorniceBase mempty
@ -571,36 +584,39 @@ data OneCornice k (p :: Pillar) a c = OneCornice
, oneCorniceBody :: !(k p a c) , oneCorniceBody :: !(k p a c)
} }
data Cornice (p :: Pillar) a c where data Cornice h (p :: Pillar) a c where
CorniceBase :: !(Colonnade Headed a c) -> Cornice Base a c CorniceBase :: !(Colonnade h a c) -> Cornice h Base a c
CorniceCap :: {-# UNPACK #-} !(Vector (OneCornice Cornice p a c)) -> Cornice (Cap p) a c CorniceCap :: {-# UNPACK #-} !(Vector (OneCornice (Cornice h) p a c)) -> Cornice h (Cap p) a c
instance Semigroup (Cornice p a c) where instance Semigroup (Cornice h p a c) where
CorniceBase a <> CorniceBase b = CorniceBase (mappend a b) CorniceBase a <> CorniceBase b = CorniceBase (mappend a b)
CorniceCap a <> CorniceCap b = CorniceCap (a Vector.++ b) CorniceCap a <> CorniceCap b = CorniceCap (a Vector.++ b)
sconcat xs@(x :| _) = case x of sconcat xs@(x :| _) = case x of
CorniceBase _ -> CorniceBase (Colonnade (vectorConcatNE (fmap (getColonnade . getCorniceBase) xs))) CorniceBase _ -> CorniceBase (Colonnade (vectorConcatNE (fmap (getColonnade . getCorniceBase) xs)))
CorniceCap _ -> CorniceCap (vectorConcatNE (fmap getCorniceCap xs)) CorniceCap _ -> CorniceCap (vectorConcatNE (fmap getCorniceCap xs))
instance ToEmptyCornice p => Monoid (Cornice p a c) where instance ToEmptyCornice p => Monoid (Cornice h p a c) where
mempty = toEmptyCornice mempty = toEmptyCornice
mappend = (Semigroup.<>) mappend = (Semigroup.<>)
mconcat xs1 = case xs1 of mconcat xs1 = case xs1 of
[] -> toEmptyCornice [] -> toEmptyCornice
x : xs2 -> Semigroup.sconcat (x :| xs2) x : xs2 -> Semigroup.sconcat (x :| xs2)
getCorniceBase :: Cornice Base a c -> Colonnade Headed a c getCorniceBase :: Cornice h Base a c -> Colonnade h a c
getCorniceBase (CorniceBase c) = c getCorniceBase (CorniceBase c) = c
getCorniceCap :: Cornice (Cap p) a c -> Vector (OneCornice Cornice p a c) getCorniceCap :: Cornice h (Cap p) a c -> Vector (OneCornice (Cornice h) p a c)
getCorniceCap (CorniceCap c) = c getCorniceCap (CorniceCap c) = c
data AnnotatedCornice (p :: Pillar) a c where data AnnotatedCornice sz (p :: Pillar) a c where
AnnotatedCorniceBase :: !(Maybe Int) -> !(Colonnade (Sized Headed) a c) -> AnnotatedCornice Base a c AnnotatedCorniceBase ::
!sz
-> !(Colonnade (Sized sz Headed) a c)
-> AnnotatedCornice sz Base a c
AnnotatedCorniceCap :: AnnotatedCorniceCap ::
!(Maybe Int) !sz
-> {-# UNPACK #-} !(Vector (OneCornice AnnotatedCornice p a c)) -> {-# UNPACK #-} !(Vector (OneCornice (AnnotatedCornice sz) p a c))
-> AnnotatedCornice (Cap p) a c -> AnnotatedCornice sz (Cap p) a c
-- data MaybeInt = JustInt {-# UNPACK #-} !Int | NothingInt -- data MaybeInt = JustInt {-# UNPACK #-} !Int | NothingInt

102
reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs
View File

@ -1,6 +1,9 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
@ -11,10 +14,12 @@ module Reflex.Dom.Colonnade
( (
-- * Types -- * Types
Cell(..) Cell(..)
, Resizable(..)
-- * Table Encoders -- * Table Encoders
, basic , basic
, static , static
, capped , capped
, cappedResizable
, cappedTraversing , cappedTraversing
, dynamic , dynamic
, dynamicCapped , dynamicCapped
@ -35,12 +40,16 @@ import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Builder as LT import qualified Data.Text.Lazy.Builder as LT
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import qualified Data.Vector as V import qualified Data.Vector as V
import Data.Map.Strict (Map)
import Data.Text (Text)
import Data.Foldable (Foldable(..),for_,forM_) import Data.Foldable (Foldable(..),for_,forM_)
import Data.Traversable (for) import Data.Traversable (for)
import Data.Semigroup (Semigroup(..)) import Data.Semigroup (Semigroup(..))
import Control.Applicative (liftA2) import Control.Applicative (liftA2)
import Reflex.Dom import Reflex.Dom
import Colonnade (Colonnade,Headed,Fascia,Cornice) import Colonnade (Colonnade,Headed,Fascia,Cornice)
import Data.Monoid (Sum(..))
import qualified Colonnade as C
import qualified Colonnade.Encode as E import qualified Colonnade.Encode as E
data Cell t m b = Cell data Cell t m b = Cell
@ -48,6 +57,13 @@ data Cell t m b = Cell
, cellContents :: !(m b) , cellContents :: !(m b)
} deriving (Functor) } deriving (Functor)
-- | In practice, this size will only ever be set to zero
-- or one.
data Resizable t h b = Resizable
{ resizableSize :: !(Dynamic t Int)
, resizableContent :: !(h b)
}
elFromCell :: (DomBuilder t m, PostBuild t m) => T.Text -> Cell t m b -> m b elFromCell :: (DomBuilder t m, PostBuild t m) => T.Text -> Cell t m b -> m b
elFromCell e (Cell attr m) = elDynAttr e attr m elFromCell e (Cell attr m) = elDynAttr e attr m
@ -99,7 +115,7 @@ basic tableAttrs = static tableAttrs (Just (M.empty,M.empty)) mempty (const memp
body :: (DomBuilder t m, PostBuild t m, Foldable f, Monoid e) body :: (DomBuilder t m, PostBuild t m, Foldable f, Monoid e)
=> M.Map T.Text T.Text => M.Map T.Text T.Text
-> (a -> M.Map T.Text T.Text) -> (a -> M.Map T.Text T.Text)
-> Colonnade p a (Cell t m e) -> Colonnade h a (Cell t m e)
-> f a -> f a
-> m e -> m e
body bodyAttrs trAttrs colonnade collection = body bodyAttrs trAttrs colonnade collection =
@ -117,6 +133,19 @@ bodyRows trAttrs colonnade collection =
unWrappedApplicative $ unWrappedApplicative $
E.rowMonoidal colonnade (WrappedApplicative . elFromCell "td") a E.rowMonoidal colonnade (WrappedApplicative . elFromCell "td") a
bodyResizable :: (DomBuilder t m, PostBuild t m, Foldable f, Monoid e)
=> Map Text Text
-> (a -> Map Text Text)
-> Colonnade (Resizable t h) a (Cell t m e)
-> f a
-> m e
bodyResizable bodyAttrs trAttrs colonnade collection = elAttr "tbody" bodyAttrs $ do
unWrappedApplicative . flip foldMap collection $ \a -> WrappedApplicative
$ elAttr "tr" (trAttrs a)
$ unWrappedApplicative
$ E.rowMonoidalHeader colonnade (\(Resizable dynSize _) (Cell cattr content) ->
WrappedApplicative (elDynAttr "td" (zipDynWith (\i at -> M.insert "colspan" (T.pack (show i)) at) dynSize cattr) content)) a
static :: static ::
(DomBuilder t m, PostBuild t m, Foldable f, Foldable h, Monoid e) (DomBuilder t m, PostBuild t m, Foldable f, Foldable h, Monoid e)
=> M.Map T.Text T.Text -- ^ @\<table\>@ tag attributes => M.Map T.Text T.Text -- ^ @\<table\>@ tag attributes
@ -160,10 +189,10 @@ sectioned tableAttrs mheadAttrs bodyAttrs trAttrs dividerContent colonnade@(E.Co
bodyRows trAttrs colonnade as bodyRows trAttrs colonnade as
encodeCorniceHead :: encodeCorniceHead ::
(DomBuilder t m, PostBuild t m, Monoid e) (DomBuilder t m, PostBuild t m, Monoid e)
=> M.Map T.Text T.Text => M.Map T.Text T.Text
-> Fascia p (M.Map T.Text T.Text) -> Fascia p (M.Map T.Text T.Text)
-> E.AnnotatedCornice p a (Cell t m e) -> E.AnnotatedCornice (Maybe Int) p a (Cell t m e)
-> m e -> m e
encodeCorniceHead headAttrs fascia annCornice = encodeCorniceHead headAttrs fascia annCornice =
elAttr "thead" headAttrs (unWrappedApplicative thead) elAttr "thead" headAttrs (unWrappedApplicative thead)
@ -172,14 +201,33 @@ encodeCorniceHead headAttrs fascia annCornice =
where addColspan = M.insert "colspan" (T.pack (show size)) where addColspan = M.insert "colspan" (T.pack (show size))
addAttr attrs = WrappedApplicative . elAttr "tr" attrs . unWrappedApplicative addAttr attrs = WrappedApplicative . elAttr "tr" attrs . unWrappedApplicative
encodeCorniceResizableHead :: forall t m e p a.
(DomBuilder t m, PostBuild t m, Monoid e)
=> M.Map T.Text T.Text
-> Fascia p (M.Map T.Text T.Text)
-> E.AnnotatedCornice (Dynamic t Int) p a (Cell t m e)
-> m e
encodeCorniceResizableHead headAttrs fascia annCornice =
elAttr "thead" headAttrs (unWrappedApplicative thead)
where
thead :: WrappedApplicative m e
thead = E.headersMonoidal (Just (fascia, addAttr)) [(th,id)] annCornice
th :: Dynamic t Int -> Cell t m e -> WrappedApplicative m e
th size (Cell attrs contents) = WrappedApplicative (elDynAttr "th" (zipDynWith addColspan size attrs) contents)
where
addColspan :: Int -> Map Text Text -> Map Text Text
addColspan i = M.insert "colspan" (T.pack (show i))
addAttr :: Map Text Text -> WrappedApplicative m b -> WrappedApplicative m b
addAttr attrs = WrappedApplicative . elAttr "tr" attrs . unWrappedApplicative
capped :: capped ::
(DomBuilder t m, PostBuild t m, MonadHold t m, Foldable f, Monoid e) (DomBuilder t m, PostBuild t m, MonadHold t m, Foldable f, Monoid e)
=> M.Map T.Text T.Text -- ^ @\<table\>@ tag attributes => M.Map T.Text T.Text -- ^ @\<table\>@ tag attributes
-> M.Map T.Text T.Text -- ^ @\<thead\>@ tag attributes -> M.Map T.Text T.Text -- ^ @\<thead\>@ tag attributes
-> M.Map T.Text T.Text -- ^ @\<tbody\>@ tag attributes -> M.Map T.Text T.Text -- ^ @\<tbody\>@ tag attributes
-> (a -> M.Map T.Text T.Text) -- ^ @\<tr\>@ tag attributes -> (a -> M.Map T.Text T.Text) -- ^ @\<tr\>@ tag attributes
-> Fascia p (M.Map T.Text T.Text) -- ^ Attributes for @\<tr\>@ elements in the @\<thead\>@ -> Fascia p (M.Map T.Text T.Text) -- ^ Attributes for @\<tr\>@ elements in the @\<thead\>@
-> Cornice p a (Cell t m e) -- ^ Data encoding strategy -> Cornice Headed p a (Cell t m e) -- ^ Data encoding strategy
-> f a -- ^ Collection of data -> f a -- ^ Collection of data
-> m e -> m e
capped tableAttrs headAttrs bodyAttrs trAttrs fascia cornice collection = capped tableAttrs headAttrs bodyAttrs trAttrs fascia cornice collection =
@ -188,6 +236,42 @@ capped tableAttrs headAttrs bodyAttrs trAttrs fascia cornice collection =
b <- body bodyAttrs trAttrs (E.discard cornice) collection b <- body bodyAttrs trAttrs (E.discard cornice) collection
return (h `mappend` b) return (h `mappend` b)
cappedResizable ::
(DomBuilder t m, PostBuild t m, MonadHold t m, Foldable f, Monoid e)
=> Map Text Text -- ^ @\<table\>@ tag attributes
-> Map Text Text -- ^ @\<thead\>@ tag attributes
-> Map Text Text -- ^ @\<tbody\>@ tag attributes
-> (a -> Map Text Text) -- ^ @\<tr\>@ tag attributes
-> Fascia p (Map Text Text) -- ^ Attributes for @\<tr\>@ elements in the @\<thead\>@
-> Cornice (Resizable t Headed) p a (Cell t m e) -- ^ Data encoding strategy
-> f a -- ^ Collection of data
-> m e
cappedResizable tableAttrs headAttrs bodyAttrs trAttrs fascia cornice collection = do
elAttr "table" tableAttrs $ do
h <- encodeCorniceResizableHead headAttrs fascia (dynamicAnnotate cornice)
b <- bodyResizable bodyAttrs trAttrs (E.discard cornice) collection
return (h `mappend` b)
dynamicAnnotate :: Reflex t
=> Cornice (Resizable t Headed) p a c
-> E.AnnotatedCornice (Dynamic t Int) p a c
dynamicAnnotate = go where
go :: forall t p a c. Reflex t
=> Cornice (Resizable t Headed) p a c
-> E.AnnotatedCornice (Dynamic t Int) p a c
go (E.CorniceBase c@(E.Colonnade cs)) =
let parentSz :: Dynamic t (Sum Int)
parentSz = foldMap (\(E.OneColonnade (Resizable sz _) _) -> (coerceDynamic sz :: Dynamic t (Sum Int))) cs
in E.AnnotatedCorniceBase (coerceDynamic parentSz) (C.mapHeadedness (\(Resizable dynSize (E.Headed content)) -> E.Sized dynSize (E.Headed content)) c)
go (E.CorniceCap children) =
let annChildren = fmap (mapOneCorniceBody go) children
parentSz :: Dynamic t (Sum Int)
parentSz = foldMap (\(E.OneCornice _ theBody) -> (coerceDynamic (E.size theBody) :: Dynamic t (Sum Int))) annChildren
in E.AnnotatedCorniceCap (coerceDynamic parentSz) annChildren
mapOneCorniceBody :: (forall p' a' c'. k p' a' c' -> j p' a' c') -> E.OneCornice k p a c -> E.OneCornice j p a c
mapOneCorniceBody f (E.OneCornice h b) = E.OneCornice h (f b)
bodyTraversing :: (DomBuilder t m, PostBuild t m, Traversable f, Monoid e) bodyTraversing :: (DomBuilder t m, PostBuild t m, Traversable f, Monoid e)
=> M.Map T.Text T.Text => M.Map T.Text T.Text
-> (a -> M.Map T.Text T.Text) -> (a -> M.Map T.Text T.Text)
@ -207,7 +291,7 @@ cappedTraversing ::
-> M.Map T.Text T.Text -- ^ @\<tbody\>@ tag attributes -> M.Map T.Text T.Text -- ^ @\<tbody\>@ tag attributes
-> (a -> M.Map T.Text T.Text) -- ^ @\<tr\>@ tag attributes -> (a -> M.Map T.Text T.Text) -- ^ @\<tr\>@ tag attributes
-> Fascia p (M.Map T.Text T.Text) -- ^ Attributes for @\<tr\>@ elements in the @\<thead\>@ -> Fascia p (M.Map T.Text T.Text) -- ^ Attributes for @\<tr\>@ elements in the @\<thead\>@
-> Cornice p a (Cell t m e) -- ^ Data encoding strategy -> Cornice Headed p a (Cell t m e) -- ^ Data encoding strategy
-> f a -- ^ Collection of data -> f a -- ^ Collection of data
-> m (f e) -> m (f e)
cappedTraversing tableAttrs headAttrs bodyAttrs trAttrs fascia cornice collection = cappedTraversing tableAttrs headAttrs bodyAttrs trAttrs fascia cornice collection =
@ -251,7 +335,7 @@ encodeCorniceHeadDynamic ::
(DomBuilder t m, PostBuild t m, Monoid e) (DomBuilder t m, PostBuild t m, Monoid e)
=> Dynamic t (M.Map T.Text T.Text) => Dynamic t (M.Map T.Text T.Text)
-> Fascia p (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) -> E.AnnotatedCornice (Maybe Int) p a (Cell t m e)
-> m e -> m e
encodeCorniceHeadDynamic headAttrs fascia annCornice = encodeCorniceHeadDynamic headAttrs fascia annCornice =
elDynAttr "thead" headAttrs (unWrappedApplicative thead) elDynAttr "thead" headAttrs (unWrappedApplicative thead)
@ -267,7 +351,7 @@ dynamicCapped ::
-> Dynamic t (M.Map T.Text T.Text) -- ^ @\<tbody\>@ tag attributes -> Dynamic t (M.Map T.Text T.Text) -- ^ @\<tbody\>@ tag attributes
-> (a -> M.Map T.Text T.Text) -- ^ @\<tr\>@ tag attributes -> (a -> M.Map T.Text T.Text) -- ^ @\<tr\>@ tag attributes
-> Fascia p (Dynamic t (M.Map T.Text T.Text)) -- ^ Attributes for @\<tr\>@ elements in the @\<thead\>@ -> Fascia p (Dynamic t (M.Map T.Text T.Text)) -- ^ Attributes for @\<tr\>@ elements in the @\<thead\>@
-> Cornice p a (Cell t m e) -- ^ Data encoding strategy -> Cornice Headed p a (Cell t m e) -- ^ Data encoding strategy
-> Dynamic t (f a) -- ^ Collection of data -> Dynamic t (f a) -- ^ Collection of data
-> m (Event t e) -> m (Event t e)
dynamicCapped tableAttrs headAttrs bodyAttrs trAttrs fascia cornice collection = dynamicCapped tableAttrs headAttrs bodyAttrs trAttrs fascia cornice collection =

2
stack.yaml
View File

@ -40,7 +40,7 @@ packages:
- 'yesod-colonnade' - 'yesod-colonnade'
- 'blaze-colonnade' - 'blaze-colonnade'
- 'siphon' - 'siphon'
- 'geolite-csv' # - 'geolite-csv'
# Dependency packages to be pulled from upstream that are not in the resolver # Dependency packages to be pulled from upstream that are not in the resolver
# (e.g., acme-missiles-0.3) # (e.g., acme-missiles-0.3)
extra-deps: extra-deps: