diff --git a/blaze-colonnade/src/Text/Blaze/Colonnade.hs b/blaze-colonnade/src/Text/Blaze/Colonnade.hs
index 35a764e..197aedb 100644
--- a/blaze-colonnade/src/Text/Blaze/Colonnade.hs
+++ b/blaze-colonnade/src/Text/Blaze/Colonnade.hs
@@ -301,40 +301,69 @@ builderCell = lazyTextCell . TBuilder.toLazyText
-- used to add attributes to the generated @\
@ elements.
encodeTable ::
(Foldable f, Foldable h)
- => Maybe Attribute -- ^ Attributes of @\@, pass 'Nothing' to omit @\@
+ => Maybe (Attribute,Attribute) -- ^ Attributes of @\@ and its @\@, pass 'Nothing' to omit @\@
-> Attribute -- ^ Attributes of @\
@ element
-> (a -> Attribute) -- ^ Attributes of each @\@ element
-> ((Html -> Html) -> c -> Html) -- ^ Wrap content and convert to 'Html'
-> Attribute -- ^ Attributes of @\@ element
- -> Colonnade h c a -- ^ How to encode data as a row
+ -> Colonnade h a c -- ^ How to encode data as a row
-> f a -- ^ Collection of data
-> Html
encodeTable mtheadAttrs tbodyAttrs trAttrs wrapContent tableAttrs colonnade xs =
H.table ! tableAttrs $ do
- for_ mtheadAttrs $ \theadAttrs -> do
- H.thead ! theadAttrs $ do
+ for_ mtheadAttrs $ \(theadAttrs,theadTrAttrs) -> do
+ H.thead ! theadAttrs $ H.tr ! theadTrAttrs $ do
Encode.headerMonoidalGeneral colonnade (wrapContent H.th)
- H.tbody ! tbodyAttrs $ do
- forM_ xs $ \x -> do
- H.tr ! trAttrs x $ Encode.rowMonoidal colonnade (wrapContent H.td) x
+ encodeBody trAttrs wrapContent tbodyAttrs colonnade xs
+
+encodeTieredHeaderTable :: Foldable f
+ => Attribute -- ^ Attributes of @\@
+ -> Attribute -- ^ Attributes of @\@ element
+ -> (a -> Attribute) -- ^ Attributes of each @\@ element in the @\
@
+ -> ((Html -> Html) -> c -> Html) -- ^ Wrap content and convert to 'Html'
+ -> Attribute -- ^ Attributes of @\@ element
+ -> Fascia p Attribute -- ^ Attributes for @\@ elements in the @\@
+ -> Cornice p a c
+ -> f a -- ^ Collection of data
+ -> Html
+encodeTieredHeaderTable theadAttrs tbodyAttrs trAttrs wrapContent tableAttrs cornice xs = do
+ let colonnade = CE.discard cornice
+ annCornice = annotate cornice
+ H.table ! tableAttrs $ do
+ H.thead ! theadAttrs $ H.tr ! trAttrs $ do
+ Encode.headerMonoidalGeneral colonnade (wrapContent H.th)
+ encodeBody trAttrs wrapContent tbodyAttrs colonnade xs
+
+encodeBody :: (Foldable h, Foldable f)
+ => (a -> Attribute) -- ^ Attributes of each @\@ element
+ -> ((Html -> Html) -> c -> Html) -- ^ Wrap content and convert to 'Html'
+ -> Attribute -- ^ Attributes of @\
@ element
+ -> Colonnade h a c -- ^ How to encode data as a row
+ -> f a -- ^ Collection of data
+ -> Html
+encodeBody trAttrs wrapContent tbodyAttrs colonnade xs = do
+ H.tbody ! tbodyAttrs $ do
+ forM_ xs $ \x -> do
+ H.tr ! trAttrs x $ Encode.rowMonoidal colonnade (wrapContent H.td) x
+
-- | Encode a table with a header. Table cells may have attributes
-- applied to them.
encodeHeadedCellTable ::
Foldable f
=> Attribute -- ^ Attributes of @\@ element
- -> Colonnade Headed Cell a -- ^ How to encode data as columns
+ -> Colonnade Headed a Cell -- ^ How to encode data as columns
-> f a -- ^ Collection of data
-> Html
encodeHeadedCellTable = encodeTable
- (Just mempty) mempty (const mempty) htmlFromCell
+ (Just (mempty,mempty)) mempty (const mempty) htmlFromCell
-- | Encode a table without a header. Table cells may have attributes
-- applied to them.
encodeHeadlessCellTable ::
Foldable f
=> Attribute -- ^ Attributes of @\@ element
- -> Colonnade Headless Cell a -- ^ How to encode data as columns
+ -> Colonnade Headless a Cell -- ^ How to encode data as columns
-> f a -- ^ Collection of data
-> Html
encodeHeadlessCellTable = encodeTable
@@ -345,18 +374,18 @@ encodeHeadlessCellTable = encodeTable
encodeHeadedHtmlTable ::
Foldable f
=> Attribute -- ^ Attributes of @\@ element
- -> Colonnade Headed Html a -- ^ How to encode data as columns
+ -> Colonnade Headed a Html -- ^ How to encode data as columns
-> f a -- ^ Collection of data
-> Html
encodeHeadedHtmlTable = encodeTable
- (Just mempty) mempty (const mempty) ($)
+ (Just (mempty,mempty)) mempty (const mempty) ($)
-- | Encode a table without a header. Table cells cannot have attributes
-- applied to them.
encodeHeadlessHtmlTable ::
Foldable f
=> Attribute -- ^ Attributes of @\@ element
- -> Colonnade Headless Html a -- ^ How to encode data as columns
+ -> Colonnade Headless a Html -- ^ How to encode data as columns
-> f a -- ^ Collection of data
-> Html
encodeHeadlessHtmlTable = encodeTable
diff --git a/colonnade/colonnade.cabal b/colonnade/colonnade.cabal
index 7fdf207..323467a 100644
--- a/colonnade/colonnade.cabal
+++ b/colonnade/colonnade.cabal
@@ -31,6 +31,7 @@ library
Colonnade
Colonnade.Encode
Colonnade.Internal
+ Colonnade.Cornice.Encode
build-depends:
base >= 4.7 && < 5
, contravariant >= 1.2 && < 1.5
diff --git a/colonnade/src/Colonnade.hs b/colonnade/src/Colonnade.hs
index 32827ae..56802bc 100644
--- a/colonnade/src/Colonnade.hs
+++ b/colonnade/src/Colonnade.hs
@@ -1,12 +1,19 @@
+
+
-- | Build backend-agnostic columnar encodings that can be
-- used to visualize tabular data.
module Colonnade
( -- * Example
-- $setup
-- * Types
+ -- ** Colonnade
Colonnade
, Headed
, Headless
+ -- ** Cornice
+ , Cornice
+ , Pillar(..)
+ , Fascia(..)
-- * Create
, headed
, headless
@@ -17,18 +24,19 @@ module Colonnade
, bool
, replaceWhen
, modifyWhen
- , mapContent
+ -- * Cornice
+ , cap
+ , recap
-- * Ascii Table
, ascii
) where
import Colonnade.Internal
-import qualified Colonnade.Encode as Encode
-import Data.Vector (Vector)
import Data.Foldable
import Data.Monoid (Endo(..))
import Control.Monad
-import Data.Functor.Contravariant
+import qualified Colonnade.Encode as Encode
+import qualified Colonnade.Cornice.Encode as CE
import qualified Data.Bool
import qualified Data.Maybe
import qualified Data.List as List
@@ -40,7 +48,7 @@ import qualified Data.Vector as Vector
-- used for the remainder of the examples in the docs:
--
-- >>> import Data.Monoid (mconcat,(<>))
--- >>> import Data.Functor.Contravariant (contramap)
+-- >>> import Data.Profunctor (lmap)
--
-- The data types we wish to encode are:
--
@@ -51,7 +59,7 @@ import qualified Data.Vector as Vector
-- One potential columnar encoding of a @Person@ would be:
--
-- >>> :{
--- let colPerson :: Colonnade Headed String Person
+-- let colPerson :: Colonnade Headed Person String
-- colPerson = mconcat
-- [ headed "Name" name
-- , headed "Age" (show . age)
@@ -76,7 +84,7 @@ import qualified Data.Vector as Vector
--
-- >>> let showDollar = (('$':) . show) :: Int -> String
-- >>> :{
--- let encodingHouse :: Colonnade Headed String House
+-- let encodingHouse :: Colonnade Headed House String
-- encodingHouse = mconcat
-- [ headed "Color" (show . color)
-- , headed "Price" (showDollar . price)
@@ -95,15 +103,15 @@ import qualified Data.Vector as Vector
-- | A single column with a header.
-headed :: c -> (a -> c) -> Colonnade Headed c a
+headed :: c -> (a -> c) -> Colonnade Headed a c
headed h = singleton (Headed h)
-- | A single column without a header.
-headless :: (a -> c) -> Colonnade Headless c a
+headless :: (a -> c) -> Colonnade Headless a c
headless = singleton Headless
-- | A single column with any kind of header. This is not typically needed.
-singleton :: f c -> (a -> c) -> Colonnade f c a
+singleton :: f c -> (a -> c) -> Colonnade f a c
singleton h = Colonnade . Vector.singleton . OneColonnade h
-- | Lift a column over a 'Maybe'. For example, if some people
@@ -123,10 +131,10 @@ singleton h = Colonnade . Vector.singleton . OneColonnade h
-- the help of 'fromMaybe':
--
-- >>> :{
--- let colOwners :: Colonnade Headed String (Person,Maybe House)
+-- let colOwners :: Colonnade Headed (Person,Maybe House) String
-- colOwners = mconcat
--- [ contramap fst colPerson
--- , contramap snd (fromMaybe "" encodingHouse)
+-- [ lmap fst colPerson
+-- , lmap snd (fromMaybe "" encodingHouse)
-- ]
-- :}
--
@@ -138,7 +146,7 @@ singleton h = Colonnade . Vector.singleton . OneColonnade h
-- | Ruth | 25 | Red | $125000 |
-- | Sonia | 12 | Green | $145000 |
-- +--------+-----+-------+---------+
-fromMaybe :: c -> Colonnade f c a -> Colonnade f c (Maybe a)
+fromMaybe :: c -> Colonnade f a c -> Colonnade f (Maybe a) c
fromMaybe c (Colonnade v) = Colonnade $ flip Vector.map v $
\(OneColonnade h encode) -> OneColonnade h (maybe c encode)
@@ -150,10 +158,10 @@ fromMaybe c (Colonnade v) = Colonnade $ flip Vector.map v $
-- >>> let allColors = [Red,Green,Blue]
-- >>> let encColor = columns (\c1 c2 -> if c1 == c2 then "✓" else "") (Headed . show) allColors
-- >>> :t encColor
--- encColor :: Colonnade Headed [Char] Color
--- >>> let encHouse = headed "Price" (showDollar . price) <> contramap color encColor
+-- encColor :: Colonnade Headed Color [Char]
+-- >>> let encHouse = headed "Price" (showDollar . price) <> lmap color encColor
-- >>> :t encHouse
--- encHouse :: Colonnade Headed [Char] House
+-- encHouse :: Colonnade Headed House [Char]
-- >>> putStr (ascii encHouse houses)
-- +---------+-----+-------+------+
-- | Price | Red | Green | Blue |
@@ -166,7 +174,7 @@ columns :: Foldable g
=> (b -> a -> c) -- ^ Cell content function
-> (b -> f c) -- ^ Header content function
-> g b -- ^ Basis for column encodings
- -> Colonnade f c a
+ -> Colonnade f a c
columns getCell getHeader = id
. Colonnade
. Vector.map (\b -> OneColonnade (getHeader b) (getCell b))
@@ -178,7 +186,7 @@ bool ::
-> (a -> Bool) -- ^ Predicate
-> (a -> c) -- ^ Contents when predicate is false
-> (a -> c) -- ^ Contents when predicate is true
- -> Colonnade f c a
+ -> Colonnade f a c
bool h p onTrue onFalse = singleton h (Data.Bool.bool <$> onFalse <*> onTrue <*> p)
-- | Modify the contents of cells in rows whose values satisfy the
@@ -188,8 +196,8 @@ bool h p onTrue onFalse = singleton h (Data.Bool.bool <$> onFalse <*> onTrue <*>
modifyWhen ::
(c -> c) -- ^ Content change
-> (a -> Bool) -- ^ Row predicate
- -> Colonnade f c a -- ^ Original 'Colonnade'
- -> Colonnade f c a
+ -> Colonnade f a c -- ^ Original 'Colonnade'
+ -> Colonnade f a c
modifyWhen changeContent p (Colonnade v) = Colonnade
( Vector.map
(\(OneColonnade h encode) -> OneColonnade h $ \a ->
@@ -202,8 +210,8 @@ modifyWhen changeContent p (Colonnade v) = Colonnade
replaceWhen ::
c -- ^ New content
-> (a -> Bool) -- ^ Row predicate
- -> Colonnade f c a -- ^ Original 'Colonnade'
- -> Colonnade f c a
+ -> Colonnade f a c -- ^ Original 'Colonnade'
+ -> Colonnade f a c
replaceWhen newContent p (Colonnade v) = Colonnade
( Vector.map
(\(OneColonnade h encode) -> OneColonnade h $ \a ->
@@ -211,69 +219,69 @@ replaceWhen newContent p (Colonnade v) = Colonnade
) v
)
--- | 'Colonnade' is covariant in its content type. Consequently, it can be
--- mapped over. There is no standard typeclass for types that are covariant
--- in their second-to-last argument, so this function is provided for
--- situations that require this.
-mapContent :: Functor f => (c1 -> c2) -> Colonnade f c1 a -> Colonnade f c2 a
-mapContent f (Colonnade v) = Colonnade
- $ Vector.map (\(OneColonnade h c) -> (OneColonnade (fmap f h) (f . c))) v
+toCornice :: Colonnade Headed a c -> Cornice Base a c
+toCornice = CorniceBase
+
+cap :: c -> Cornice p a c -> Cornice (Cap p) a c
+cap h cor = CorniceCap (V.singleton (OneCornice h cor))
+
+
+asciiMulti :: Foldable f
+ => Cornice p a String -- ^ columnar encoding
+ -> f a -- ^ rows
+ -> String
+asciiMulti cor xs =
+ let annCor = CE.annotateFinely (\x y -> x + y + 3) id
+ List.length xs cor
+ in CE.headersMonoidal (Right (\s -> s ++ "\n")) (\sz c -> rightPad sz ' ' c) annCor
+
-- | Render a collection of rows as an ascii table. The table\'s columns are
-- specified by the given 'Colonnade'. This implementation is inefficient and
-- does not provide any wrapping behavior. It is provided so that users can
--- try out @colonnade@ in ghci and so that @doctest@ can verify examples
+-- try out @colonnade@ in ghci and so that @doctest@ can verify example
-- code in the haddocks.
ascii :: Foldable f
- => Colonnade Headed String a -- ^ columnar encoding
+ => Colonnade Headed a String -- ^ columnar encoding
-> f a -- ^ rows
-> String
-ascii enc xs =
- let theHeader :: [(Int,String)]
- theHeader = (zip (enumFrom 0) . map (\s -> " " ++ s ++ " ")) (toList (Encode.header id enc))
- theBody :: [[(Int,String)]]
- theBody = map (zip (enumFrom 0) . map (\s -> " " ++ s ++ " ") . toList . Encode.row id enc) (toList xs)
- sizes :: [Int]
- sizes = ($ replicate (length theHeader) 1) $ appEndo $ mconcat
- [ foldMap (\(i,str) -> Endo (replaceAt i (length str))) theHeader
- , (foldMap . foldMap) (\(i,str) -> Endo (replaceAt i (length str))) theBody
+ascii col xs =
+ let sizedCol = Encode.sizeColumns List.length xs col
+ divider = concat
+ [ "+"
+ , Encode.headerMonoidalFull sizedCol
+ (\(Sized sz _) -> hyphens (sz + 2) ++ "+")
+ , "\n"
]
- paddedHeader :: [String]
- paddedHeader = map (\(i,str) -> rightPad (atDef 1 sizes i) ' ' str) theHeader
- paddedBody :: [[String]]
- paddedBody = (map . map) (\(i,str) -> rightPad (atDef 1 sizes i) ' ' str) theBody
- divider :: String
- divider = "+" ++ join (List.intersperse "+" (map (\i -> replicate i '-') sizes)) ++ "+"
- headerStr :: String
- headerStr = "|" ++ join (List.intersperse "|" paddedHeader) ++ "|"
- bodyStr :: String
- bodyStr = List.unlines (map ((\s -> "|" ++ s ++ "|") . join . List.intersperse "|") paddedBody)
- in divider ++ "\n" ++ headerStr
- ++ "\n" ++ divider
- ++ "\n" ++ bodyStr ++ divider ++ "\n"
-
-
--- this has no effect if the index is out of bounds
-replaceAt :: Ord a => Int -> a -> [a] -> [a]
-replaceAt _ _ [] = []
-replaceAt n v (a:as) = if n > 0
- then a : replaceAt (n - 1) v as
- else (max v a) : as
+ rowContents = foldMap
+ (\x -> concat
+ [ "|"
+ , Encode.rowMonoidalHeader
+ sizedCol
+ (\(Sized sz _) c -> " " ++ rightPad sz ' ' c ++ " |")
+ x
+ , "\n"
+ ]
+ ) xs
+ in List.concat
+ [ divider
+ , concat
+ [ "|"
+ , Encode.headerMonoidalFull sizedCol
+ (\(Sized s (Headed h)) -> " " ++ rightPad s ' ' h ++ " |")
+ , "\n"
+ ]
+ , divider
+ , rowContents
+ , divider
+ ]
+
+hyphens :: Int -> String
+hyphens n = List.replicate n '-'
rightPad :: Int -> a -> [a] -> [a]
rightPad m a xs = take m $ xs ++ repeat a
-atDef :: a -> [a] -> Int -> a
-atDef def = Data.Maybe.fromMaybe def .^ atMay where
- (.^) f g x1 x2 = f (g x1 x2)
- atMay = eitherToMaybe .^ at_
- eitherToMaybe = either (const Nothing) Just
- at_ xs o | o < 0 = Left $ "index must not be negative, index=" ++ show o
- | otherwise = f o xs
- where f 0 (z:_) = Right z
- f i (_:zs) = f (i-1) zs
- f i [] = Left $ "index too large, index=" ++ show o ++ ", length=" ++ show (o-i)
-
-- data Company = Company String String Int
--
-- data Company = Company
diff --git a/colonnade/src/Colonnade/Cornice/Encode.hs b/colonnade/src/Colonnade/Cornice/Encode.hs
new file mode 100644
index 0000000..9e26c96
--- /dev/null
+++ b/colonnade/src/Colonnade/Cornice/Encode.hs
@@ -0,0 +1,203 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
+
+{-# OPTIONS_GHC -Wall -fno-warn-unused-imports -fno-warn-unticked-promoted-constructors -Werror #-}
+module Colonnade.Cornice.Encode
+ ( annotate
+ , annotateFinely
+ , size
+ , endow
+ , discard
+ , headersMonoidal
+ ) where
+
+import Colonnade.Internal
+import Data.Vector (Vector)
+import Control.Monad.ST (ST,runST)
+import Data.Monoid
+import qualified Data.Vector as V
+import qualified Colonnade.Encode as E
+
+discard :: Cornice p a c -> Colonnade Headed a c
+discard = go where
+ go :: forall p a c. Cornice p a c -> Colonnade Headed a c
+ go (CorniceBase c) = c
+ 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 f x = case x of
+ CorniceBase colonnade -> colonnade
+ CorniceCap v -> Colonnade (V.concatMap (\(OneCornice h b) -> go h b) v)
+ where
+ go :: forall p'. c -> Cornice p' a c -> Vector (OneColonnade Headed a c)
+ 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
+
+annotate :: Cornice p a c -> AnnotatedCornice p a c
+annotate = go where
+ go :: forall p a c. Cornice p a c -> AnnotatedCornice p a c
+ go (CorniceBase c) = AnnotatedCorniceBase (mapHeadedness (Sized 1) c)
+ go (CorniceCap children) =
+ let annChildren = fmap (mapOneCorniceBody go) children
+ in AnnotatedCorniceCap
+ ( ( ( V.foldl' (combineJustInt (+))
+ ) Nothing . V.map (size . oneCorniceBody)
+ ) annChildren
+ )
+ annChildren
+
+combineJustInt :: (Int -> Int -> Int) -> Maybe Int -> Maybe Int -> Maybe Int
+combineJustInt f acc el = case acc of
+ Nothing -> case el of
+ Nothing -> Nothing
+ Just i -> Just i
+ Just i -> case el of
+ Nothing -> Just i
+ Just j -> Just (f i j)
+
+mapJustInt :: (Int -> Int) -> Maybe Int -> Maybe Int
+mapJustInt _ Nothing = Nothing
+mapJustInt f (Just i) = Just (f i)
+
+annotateFinely :: Foldable f
+ => (Int -> Int -> Int) -- ^ fold function
+ -> (Int -> Int) -- ^ finalize
+ -> (c -> Int) -- ^ Get size from content
+ -> f a
+ -> Cornice p a c
+ -> AnnotatedCornice p a c
+annotateFinely g finish toSize xs cornice = runST $ do
+ m <- newMutableSizedCornice cornice
+ sizeColonnades toSize xs m
+ freezeMutableSizedCornice g finish m
+
+sizeColonnades :: forall f s p a c.
+ Foldable f
+ => (c -> Int) -- ^ Get size from content
+ -> f a
+ -> MutableSizedCornice s p a c
+ -> ST s ()
+sizeColonnades toSize xs cornice = do
+ goHeader cornice
+ mapM_ (goRow cornice) xs
+ where
+ goRow :: forall p'. MutableSizedCornice s p' a c -> a -> ST s ()
+ goRow (MutableSizedCorniceBase c) a = E.rowUpdateSize toSize c a
+ goRow (MutableSizedCorniceCap children) a = mapM_ (flip goRow a . oneCorniceBody) children
+ goHeader :: forall p'. MutableSizedCornice s p' a c -> ST s ()
+ goHeader (MutableSizedCorniceBase c) = E.headerUpdateSize toSize c
+ goHeader (MutableSizedCorniceCap children) = mapM_ (goHeader . oneCorniceBody) children
+
+freezeMutableSizedCornice :: forall s p a c.
+ (Int -> Int -> Int) -- ^ fold function
+ -> (Int -> Int) -- ^ finalize
+ -> MutableSizedCornice s p a c
+ -> ST s (AnnotatedCornice p a c)
+freezeMutableSizedCornice step finish = go
+ where
+ go :: forall p' a' c'. MutableSizedCornice s p' a' c' -> ST s (AnnotatedCornice p' a' c')
+ go (MutableSizedCorniceBase msc) =
+ fmap AnnotatedCorniceBase (E.freezeMutableSizedColonnade msc)
+ go (MutableSizedCorniceCap v1) = do
+ v2 <- V.mapM (traverseOneCorniceBody go) v1
+ let sz = (mapJustInt finish . V.foldl' (combineJustInt step) Nothing . V.map (size . oneCorniceBody)) v2
+ return $ AnnotatedCorniceCap sz v2
+
+newMutableSizedCornice :: forall s p a c.
+ Cornice p a c
+ -> ST s (MutableSizedCornice s p a c)
+newMutableSizedCornice = go where
+ go :: forall p'. Cornice p' a c -> ST s (MutableSizedCornice s p' a c)
+ go (CorniceBase c) = fmap MutableSizedCorniceBase (E.newMutableSizedColonnade c)
+ go (CorniceCap v) = fmap MutableSizedCorniceCap (V.mapM (traverseOneCorniceBody go) v)
+
+traverseOneCorniceBody :: Monad m => (k p a c -> m (j p a c)) -> OneCornice k p a c -> m (OneCornice j p a c)
+traverseOneCorniceBody f (OneCornice h b) = fmap (OneCornice h) (f b)
+
+mapHeadedness :: (forall x. h x -> h' x) -> Colonnade h a c -> Colonnade h' a c
+mapHeadedness f (Colonnade v) =
+ Colonnade (V.map (\(OneColonnade h c) -> OneColonnade (f h) c) v)
+
+-- annotate ::
+-- Int -- ^ initial
+-- -> (Int -> Int -> Int) -- ^ fold function
+-- -> (Int -> Int) -- ^ finalize
+-- -> Cornice p a c
+-- -> AnnotatedCornice p a c
+-- annotate i0 g finish = go where
+-- go :: forall p a c. Cornice p a c -> AnnotatedCornice p a c
+-- go (CorniceBase c) = AnnotatedCorniceBase c
+-- go (CorniceCap children) =
+-- let annChildren = fmap (mapOneCorniceBody go) children
+-- in AnnotatedCorniceCap ((finish . V.foldl' g i0 . V.map (size . oneCorniceBody)) annChildren) annChildren
+
+-- | This is an O(1) operation, sort of
+size :: AnnotatedCornice p a c -> Maybe Int
+size x = case x of
+ AnnotatedCorniceBase (Colonnade v) -> if V.length v > 0
+ then Just ((V.sum . V.map (sizedSize . oneColonnadeHead)) v)
+ else Nothing
+ AnnotatedCorniceCap sz _ -> sz
+
+mapOneCorniceBody :: (forall p' a' c'. k p' a' c' -> j p' a' c') -> OneCornice k p a c -> OneCornice j p a c
+mapOneCorniceBody f (OneCornice h b) = OneCornice h (f b)
+
+mapOneColonnadeHeader :: Functor h => (c -> c) -> OneColonnade h a c -> OneColonnade h a c
+mapOneColonnadeHeader f (OneColonnade h b) = OneColonnade (fmap f h) b
+
+headersMonoidal :: forall r m c p a.
+ Monoid m
+ => Either (Fascia p r, r -> m -> m) (m -> m) -- ^ Apply the Fascia header row content
+ -> (Int -> c -> m) -- ^ Build content from cell content and size
+ -> AnnotatedCornice p a c
+ -> m
+headersMonoidal wrapRow fromContent = go wrapRow
+ where
+ go :: forall p'. Either (Fascia p' r, r -> m -> m) (m -> m) -> AnnotatedCornice p' a c -> m
+ go ef (AnnotatedCorniceBase (Colonnade v)) =
+ let g :: m -> m
+ g m = case ef of
+ Right f -> f m
+ Left (FasciaBase r, f) -> f r m
+ in foldMap (\(OneColonnade (Sized sz (Headed h)) _) ->
+ g (fromContent sz h)) v
+ go ef (AnnotatedCorniceCap _ v) =
+ let g :: m -> m
+ g m = case ef of
+ Right f -> f m
+ Left (FasciaCap r _, f) -> f r m
+ in foldMap (\(OneCornice h b) ->
+ (case size b of
+ Nothing -> mempty
+ Just sz -> g (fromContent sz h))
+ ) v
+ <> case ef of
+ Right f -> case flattenAnnotated v of
+ Nothing -> mempty
+ Just annCoreNext -> go (Right f) annCoreNext
+ Left (FasciaCap _ fn, f) -> case flattenAnnotated v of
+ Nothing -> mempty
+ Just annCoreNext -> go (Left (fn,f)) annCoreNext
+
+flattenAnnotated :: Vector (OneCornice AnnotatedCornice p a c) -> Maybe (AnnotatedCornice p a c)
+flattenAnnotated v = case v V.!? 0 of
+ Nothing -> Nothing
+ Just (OneCornice _ x) -> Just $ case x of
+ AnnotatedCorniceBase _ -> flattenAnnotatedBase v
+ AnnotatedCorniceCap m _ -> flattenAnnotatedCap m v
+
+flattenAnnotatedBase :: Vector (OneCornice AnnotatedCornice Base a c) -> AnnotatedCornice Base a c
+flattenAnnotatedBase = AnnotatedCorniceBase
+ . Colonnade
+ . V.concatMap
+ (\(OneCornice _ (AnnotatedCorniceBase (Colonnade v))) -> v)
+
+flattenAnnotatedCap :: Maybe Int -> Vector (OneCornice AnnotatedCornice (Cap p) a c) -> AnnotatedCornice (Cap p) a c
+flattenAnnotatedCap m = AnnotatedCorniceCap m . V.concatMap getTheVector
+
+getTheVector :: OneCornice AnnotatedCornice (Cap p) a c -> Vector (OneCornice AnnotatedCornice p a c)
+getTheVector (OneCornice _ (AnnotatedCorniceCap _ v)) = v
+
+
diff --git a/colonnade/src/Colonnade/Encode.hs b/colonnade/src/Colonnade/Encode.hs
index 61017e3..07085f9 100644
--- a/colonnade/src/Colonnade/Encode.hs
+++ b/colonnade/src/Colonnade/Encode.hs
@@ -30,30 +30,43 @@ module Colonnade.Encode
, rowMonadic_
, rowMonadicWith
, rowMonoidal
+ , rowMonoidalHeader
, header
, headerMonadic
, headerMonadic_
, headerMonadicGeneral
, headerMonadicGeneral_
, headerMonoidalGeneral
+ , headerMonoidalFull
, bothMonadic_
+ , freezeMutableSizedColonnade
+ , newMutableSizedColonnade
+ , rowUpdateSize
+ , headerUpdateSize
+ , sizeColumns
) where
import Colonnade.Internal
import Data.Vector (Vector)
import Data.Foldable
+import Control.Monad.ST (ST,runST)
+import Data.Monoid
import qualified Data.Vector as Vector
+import qualified Data.Vector.Unboxed.Mutable as MVU
+import qualified Data.Vector.Unboxed as VU
+import qualified Data.Vector as V
+import qualified Data.Vector.Generic as GV
-- | Consider providing a variant the produces a list
-- instead. It may allow more things to get inlined
-- in to a loop.
-row :: (c1 -> c2) -> Colonnade f c1 a -> a -> Vector c2
+row :: (c1 -> c2) -> Colonnade f a c1 -> a -> Vector c2
row g (Colonnade v) a = flip Vector.map v $
\(OneColonnade _ encode) -> g (encode a)
bothMonadic_ :: Monad m
- => Colonnade Headed content a
- -> (content -> content -> m b)
+ => Colonnade Headed a c
+ -> (c -> c -> m b)
-> a
-> m ()
bothMonadic_ (Colonnade v) g a =
@@ -61,8 +74,8 @@ bothMonadic_ (Colonnade v) g a =
rowMonadic ::
(Monad m, Monoid b)
- => Colonnade f content a
- -> (content -> m b)
+ => Colonnade f a c
+ -> (c -> m b)
-> a
-> m b
rowMonadic (Colonnade v) g a =
@@ -71,8 +84,8 @@ rowMonadic (Colonnade v) g a =
rowMonadic_ ::
Monad m
- => Colonnade f content a
- -> (content -> m b)
+ => Colonnade f a c
+ -> (c -> m b)
-> a
-> m ()
rowMonadic_ (Colonnade v) g a =
@@ -80,19 +93,75 @@ rowMonadic_ (Colonnade v) g a =
rowMonoidal ::
Monoid m
- => Colonnade h c a
+ => Colonnade h a c
-> (c -> m)
-> a
-> m
rowMonoidal (Colonnade v) g a =
- foldMap (\e -> g (oneColonnadeEncode e a)) v
+ foldMap (\(OneColonnade h encode) -> g (encode a)) v
+
+rowMonoidalHeader ::
+ Monoid m
+ => Colonnade h a c
+ -> (h c -> c -> m)
+ -> a
+ -> m
+rowMonoidalHeader (Colonnade v) g a =
+ foldMap (\(OneColonnade h encode) -> g h (encode a)) v
+
+rowUpdateSize ::
+ (c -> Int) -- ^ Get size from content
+ -> MutableSizedColonnade s h a c
+ -> a
+ -> ST s ()
+rowUpdateSize toSize (MutableSizedColonnade v mv) a = if MVU.length mv /= V.length v
+ then error "rowMonoidalSize: vector sizes mismatched"
+ else V.imapM_ (\ix (OneColonnade _ encode) ->
+ MVU.modify mv (\oldSize -> max oldSize (toSize (encode a))) ix
+ ) v
+
+headerUpdateSize :: Foldable h
+ => (c -> Int) -- ^ Get size from content
+ -> MutableSizedColonnade s h a c
+ -> ST s ()
+headerUpdateSize toSize (MutableSizedColonnade v mv) = if MVU.length mv /= V.length v
+ then error "rowMonoidalSize: vector sizes mismatched"
+ else V.imapM_ (\ix (OneColonnade h _) ->
+ MVU.modify mv (\oldSize -> max oldSize (foldl' (\sz c -> max sz (toSize c)) 0 h)) ix
+ ) v
+
+sizeColumns :: (Foldable f, Foldable h)
+ => (c -> Int) -- ^ Get size from content
+ -> f a
+ -> Colonnade h a c
+ -> Colonnade (Sized h) a c
+sizeColumns toSize rows colonnade = runST $ do
+ mcol <- newMutableSizedColonnade colonnade
+ headerUpdateSize toSize mcol
+ mapM_ (rowUpdateSize toSize mcol) rows
+ freezeMutableSizedColonnade mcol
+
+newMutableSizedColonnade :: Colonnade h a c -> ST s (MutableSizedColonnade s h a c)
+newMutableSizedColonnade (Colonnade v) = do
+ mv <- MVU.replicate (V.length v) 0
+ return (MutableSizedColonnade v mv)
+
+freezeMutableSizedColonnade :: MutableSizedColonnade s h a c -> ST s (Colonnade (Sized h) a c)
+freezeMutableSizedColonnade (MutableSizedColonnade v mv) =
+ if MVU.length mv /= V.length v
+ then error "rowMonoidalSize: vector sizes mismatched"
+ else do
+ sizeVec <- VU.freeze mv
+ return $ Colonnade
+ $ V.map (\(OneColonnade h enc,sz) -> OneColonnade (Sized sz h) enc)
+ $ V.zip v (GV.convert sizeVec)
rowMonadicWith ::
(Monad m)
=> b
-> (b -> b -> b)
- -> Colonnade f content a
- -> (content -> m b)
+ -> Colonnade f a c
+ -> (c -> m b)
-> a
-> m b
rowMonadicWith bempty bappend (Colonnade v) g a =
@@ -101,15 +170,15 @@ rowMonadicWith bempty bappend (Colonnade v) g a =
return (bappend bl br)
) bempty v
-header :: (c1 -> c2) -> Colonnade Headed c1 a -> Vector c2
+header :: (c1 -> c2) -> Colonnade Headed a c1 -> Vector c2
header g (Colonnade v) =
Vector.map (g . getHeaded . oneColonnadeHead) v
-- | This function is a helper for abusing 'Foldable' to optionally
-- render a header. Its future is uncertain.
headerMonadicGeneral :: (Monad m, Monoid b, Foldable h)
- => Colonnade h content a
- -> (content -> m b)
+ => Colonnade h a c
+ -> (c -> m b)
-> m b
headerMonadicGeneral (Colonnade v) g = id
$ fmap (mconcat . Vector.toList)
@@ -117,36 +186,43 @@ headerMonadicGeneral (Colonnade v) g = id
headerMonadic ::
(Monad m, Monoid b)
- => Colonnade Headed content a
- -> (content -> m b)
+ => Colonnade Headed a c
+ -> (c -> m b)
-> m b
headerMonadic (Colonnade v) g =
fmap (mconcat . Vector.toList) $ Vector.mapM (g . getHeaded . oneColonnadeHead) v
headerMonadicGeneral_ ::
(Monad m, Foldable h)
- => Colonnade h content a
- -> (content -> m b)
+ => Colonnade h a c
+ -> (c -> m b)
-> m ()
headerMonadicGeneral_ (Colonnade v) g =
Vector.mapM_ (mapM_ g . oneColonnadeHead) v
headerMonoidalGeneral ::
(Monoid m, Foldable h)
- => Colonnade h c a
+ => Colonnade h a c
-> (c -> m)
-> m
headerMonoidalGeneral (Colonnade v) g =
foldMap (foldMap g . oneColonnadeHead) v
-
+
+headerMonoidalFull ::
+ Monoid m
+ => Colonnade h a c
+ -> (h c -> m)
+ -> m
+headerMonoidalFull (Colonnade v) g = foldMap (g . oneColonnadeHead) v
headerMonadic_ ::
(Monad m)
- => Colonnade Headed content a
- -> (content -> m b)
+ => Colonnade Headed a c
+ -> (c -> m b)
-> m ()
headerMonadic_ (Colonnade v) g = Vector.mapM_ (g . getHeaded . oneColonnadeHead) v
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
+
diff --git a/colonnade/src/Colonnade/Internal.hs b/colonnade/src/Colonnade/Internal.hs
index 36c0528..72e0a34 100644
--- a/colonnade/src/Colonnade/Internal.hs
+++ b/colonnade/src/Colonnade/Internal.hs
@@ -1,14 +1,30 @@
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
{-# OPTIONS_HADDOCK not-home #-}
+{-# OPTIONS_GHC -Wall -fno-warn-unused-imports -fno-warn-unticked-promoted-constructors -Werror #-}
module Colonnade.Internal
- ( Colonnade(..)
+ ( -- * Colonnade
+ Colonnade(..)
, OneColonnade(..)
, Headed(..)
, Headless(..)
+ -- * Cornice
+ , Cornice(..)
+ , AnnotatedCornice(..)
+ , OneCornice(..)
+ , Pillar(..)
+ , ToEmptyCornice(..)
+ , Fascia(..)
+ -- * Sizing
+ , Sized(..)
+ , MutableSizedColonnade(..)
+ , MutableSizedCornice(..)
) where
import Data.Vector (Vector)
@@ -17,14 +33,20 @@ import Data.Functor.Contravariant.Divisible (Divisible(..))
import Control.Exception (Exception)
import Data.Typeable (Typeable)
import Data.Profunctor (Profunctor(..))
+import Data.Semigroup (Semigroup)
+import Data.List.NonEmpty (NonEmpty((:|)))
+import Data.Foldable (toList)
+import qualified Data.Vector.Unboxed.Mutable as MVU
+import qualified Data.Semigroup as Semigroup
import qualified Data.Vector as Vector
+import qualified Data.Vector.Generic as VG
-- | As the first argument to the 'Colonnade' type
-- constructor, this indictates that the columnar encoding has
-- a header. This type is isomorphic to 'Identity' but is
-- given a new name to clarify its intent:
--
--- > example :: Colonnade Headed Text Foo
+-- > example :: Colonnade Headed Foo Text
--
-- The term @example@ represents a columnar encoding of @Foo@
-- in which the columns have headings.
@@ -36,13 +58,18 @@ newtype Headed a = Headed { getHeaded :: a }
-- a header. This type is isomorphic to 'Proxy' but is
-- given a new name to clarify its intent:
--
--- > example :: Colonnade Headless Text Foo
+-- > example :: Colonnade Headless Foo Text
--
-- The term @example@ represents a columnar encoding of @Foo@
-- in which the columns do not have headings.
data Headless a = Headless
deriving (Eq,Ord,Functor,Show,Read,Foldable)
+data Sized f a = Sized
+ { sizedSize :: {-# UNPACK #-} !Int
+ , sizedContent :: !(f a)
+ } deriving (Functor, Foldable)
+
instance Contravariant Headless where
contramap _ Headless = Headless
@@ -66,13 +93,13 @@ instance Functor h => Profunctor (OneColonnade h) where
-- that represent HTML with element attributes are provided that serve
-- as the content type. Presented more visually:
--
--- > +---- Content (Text, ByteString, Html, etc.)
+-- > +---- Value consumed to build a row
-- > |
-- > v
--- > Colonnade h c a
+-- > Colonnade h a c
-- > ^ ^
-- > | |
--- > | +-- Value consumed to build a row
+-- > | +-- Content (Text, ByteString, Html, etc.)
-- > |
-- > +------ Headedness (Headed or Headless)
--
@@ -89,6 +116,82 @@ newtype Colonnade h a c = Colonnade
instance Functor h => Profunctor (Colonnade h) where
rmap = fmap
- lmap f (Colonnade v) = Colonnade
- (Vector.map (lmap f) v)
+ lmap f (Colonnade v) = Colonnade (Vector.map (lmap f) v)
+
+instance Semigroup (Colonnade h a c) where
+ Colonnade a <> Colonnade b = Colonnade (a Vector.++ b)
+ sconcat xs = Colonnade (vectorConcatNE (fmap getColonnade xs))
+
+data MutableSizedColonnade s h a c = MutableSizedColonnade
+ { mutableSizedColonnadeColumns :: {-# UNPACK #-} !(Vector (OneColonnade h a c))
+ , mutableSizedColonnadeSizes :: {-# UNPACK #-} !(MVU.STVector s Int)
+ }
+
+-- | Isomorphic to the natural numbers. Only the promoted version of
+-- this type is used.
+data Pillar = Cap !Pillar | Base
+
+class ToEmptyCornice (p :: Pillar) where
+ toEmptyCornice :: Cornice p a c
+
+instance ToEmptyCornice Base where
+ toEmptyCornice = CorniceBase mempty
+
+instance ToEmptyCornice (Cap p) where
+ toEmptyCornice = CorniceCap Vector.empty
+
+data Fascia (p :: Pillar) r where
+ FasciaBase :: !r -> Fascia Base r
+ FasciaCap :: !r -> Fascia p r -> Fascia (Cap p) r
+
+data OneCornice k (p :: Pillar) a c = OneCornice
+ { oneCorniceHead :: !c
+ , oneCorniceBody :: !(k p a c)
+ }
+
+data Cornice (p :: Pillar) a c where
+ CorniceBase :: !(Colonnade Headed a c) -> Cornice Base a c
+ CorniceCap :: {-# UNPACK #-} !(Vector (OneCornice Cornice p a c)) -> Cornice (Cap p) a c
+
+instance Semigroup (Cornice p a c) where
+ CorniceBase a <> CorniceBase b = CorniceBase (mappend a b)
+ CorniceCap a <> CorniceCap b = CorniceCap (a Vector.++ b)
+ sconcat xs@(x :| _) = case x of
+ CorniceBase _ -> CorniceBase (Colonnade (vectorConcatNE (fmap (getColonnade . getCorniceBase) xs)))
+ CorniceCap _ -> CorniceCap (vectorConcatNE (fmap getCorniceCap xs))
+
+instance ToEmptyCornice p => Monoid (Cornice p a c) where
+ mempty = toEmptyCornice
+ mappend = (Semigroup.<>)
+ mconcat xs1 = case xs1 of
+ [] -> toEmptyCornice
+ x : xs2 -> Semigroup.sconcat (x :| xs2)
+
+getCorniceBase :: Cornice Base a c -> Colonnade Headed a c
+getCorniceBase (CorniceBase c) = c
+
+getCorniceCap :: Cornice (Cap p) a c -> Vector (OneCornice Cornice p a c)
+getCorniceCap (CorniceCap c) = c
+
+data AnnotatedCornice (p :: Pillar) a c where
+ AnnotatedCorniceBase :: !(Colonnade (Sized Headed) a c) -> AnnotatedCornice Base a c
+ AnnotatedCorniceCap ::
+ !(Maybe Int)
+ -> {-# UNPACK #-} !(Vector (OneCornice AnnotatedCornice p a c))
+ -> AnnotatedCornice (Cap p) a c
+
+data MutableSizedCornice s (p :: Pillar) a c where
+ MutableSizedCorniceBase ::
+ {-# UNPACK #-} !(MutableSizedColonnade s Headed a c)
+ -> MutableSizedCornice s Base a c
+ MutableSizedCorniceCap ::
+ {-# UNPACK #-} !(Vector (OneCornice (MutableSizedCornice s) p a c))
+ -> MutableSizedCornice s (Cap p) a c
+
+-- data MaybeInt = JustInt {-# UNPACK #-} !Int | NothingInt
+
+-- | This is provided with vector-0.12, but we include a copy here
+-- for compatibility.
+vectorConcatNE :: NonEmpty (Vector a) -> Vector a
+vectorConcatNE = Vector.concat . toList
diff --git a/stack.yaml b/stack.yaml
index f4b02b9..5a6af13 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -15,7 +15,7 @@
# resolver:
# name: custom-snapshot
# location: "./custom-snapshot.yaml"
-resolver: lts-7.18
+resolver: lts-8.0
# User packages to be built.
# Various formats can be used as shown in the example below.