some changes

blaze-colonnade/src/Text/Blaze/Colonnade.hs

@@ -301,40 +301,69 @@ builderCell = lazyTextCell . TBuilder.toLazyText
 --   used to add attributes to the generated @\<tr\>@ elements.
 encodeTable ::
      (Foldable f, Foldable h)
-  => Maybe Attribute -- ^ Attributes of @\<thead\>@, pass 'Nothing' to omit @\<thead\>@
+  => Maybe (Attribute,Attribute) -- ^ Attributes of @\<thead\>@ and its @\<tr\>@, pass 'Nothing' to omit @\<thead\>@
   -> Attribute -- ^ Attributes of @\<tbody\>@ element
   -> (a -> Attribute) -- ^ Attributes of each @\<tr\>@ element
   -> ((Html -> Html) -> c -> Html) -- ^ Wrap content and convert to 'Html'
   -> Attribute -- ^ Attributes of @\<table\>@ 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 @\<thead\>@ 
+  -> Attribute -- ^ Attributes of @\<tbody\>@ element
+  -> (a -> Attribute) -- ^ Attributes of each @\<tr\>@ element in the @\<tbody\>@
+  -> ((Html -> Html) -> c -> Html) -- ^ Wrap content and convert to 'Html'
+  -> Attribute -- ^ Attributes of @\<table\>@ element
+  -> Fascia p Attribute -- ^ Attributes for @\<tr\>@ elements in the @\<thead\>@
+  -> 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 @\<tr\>@ element
+  -> ((Html -> Html) -> c -> Html) -- ^ Wrap content and convert to 'Html'
+  -> Attribute -- ^ Attributes of @\<tbody\>@ 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 @\<table\>@ 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 @\<table\>@ 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 @\<table\>@ 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 @\<table\>@ 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

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

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

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
+
+

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
 
+

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
 

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.