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.