diff --git a/colonnade/colonnade.cabal b/colonnade/colonnade.cabal index 2635110..7f4d4cb 100644 --- a/colonnade/colonnade.cabal +++ b/colonnade/colonnade.cabal @@ -28,9 +28,8 @@ cabal-version: >=1.10 library hs-source-dirs: src exposed-modules: - Colonnade.Types - Colonnade.Encoding - Colonnade.Decoding + Colonnade + Colonnade.Internal build-depends: base >= 4.7 && < 5 , contravariant >= 1.2 && < 1.5 diff --git a/colonnade/src/Colonnade.hs b/colonnade/src/Colonnade.hs new file mode 100644 index 0000000..049c851 --- /dev/null +++ b/colonnade/src/Colonnade.hs @@ -0,0 +1,361 @@ +-- | Build backend-agnostic columnar encodings that can be +-- used to visualize tabular data. +module Colonnade + ( -- * Example + -- $setup + -- * Types + Colonnade + , Headed + , Headless + -- * Create + , headed + , headless + , singleton + -- * Transform + , fromMaybe + , columns + , bool + , replaceWhen + , mapContent + -- * Render + -- $render + , runRow + , runRowMonadic + , runRowMonadic_ + , runRowMonadicWith + , runHeader + , runHeaderMonadic + , runHeaderMonadic_ + , runHeaderMonadicGeneral + , runHeaderMonadicGeneral_ + , runBothMonadic_ + -- * Ascii Table + , ascii + ) where + +import Colonnade.Internal +import Data.Vector (Vector) +import Data.Foldable +import Data.Monoid (Endo(..)) +import Control.Monad +import Data.Functor.Contravariant +import qualified Data.Bool +import qualified Data.Maybe +import qualified Data.List as List +import qualified Data.Vector as Vector + +-- $setup +-- +-- First, let\'s bring in some neccessary imports that will be +-- used for the remainder of the examples in the docs: +-- +-- >>> import Data.Monoid (mconcat,(<>)) +-- >>> import Data.Functor.Contravariant (contramap) +-- +-- Assume that the data we wish to encode is: +-- +-- >>> data Color = Red | Green | Blue deriving (Show,Eq) +-- >>> data Person = Person { name :: String, age :: Int } +-- >>> data House = House { color :: Color, price :: Int } +-- +-- One potential columnar encoding of a @Person@ would be: +-- +-- >>> :{ +-- let encodingPerson :: Colonnade Headed String Person +-- encodingPerson = mconcat +-- [ headed "Name" name +-- , headed "Age" (show . age) +-- ] +-- :} +-- +-- The type signature on @encodingPerson@ is not neccessary +-- but is included for clarity. We can feed data into this encoding +-- to build a table: +-- +-- >>> let people = [Person "David" 63, Person "Ava" 34, Person "Sonia" 12] +-- >>> putStr (ascii encodingPerson people) +-- +-------+-----+ +-- | Name | Age | +-- +-------+-----+ +-- | David | 63 | +-- | Ava | 34 | +-- | Sonia | 12 | +-- +-------+-----+ +-- +-- Similarly, we can build a table of houses with: +-- +-- >>> let showDollar = (('$':) . show) :: Int -> String +-- >>> :{ +-- let encodingHouse :: Colonnade Headed String House +-- encodingHouse = mconcat +-- [ headed "Color" (show . color) +-- , headed "Price" (showDollar . price) +-- ] +-- :} +-- +-- >>> let houses = [House Green 170000, House Blue 115000, House Green 150000] +-- >>> putStr (ascii encodingHouse houses) +-- +-------+---------+ +-- | Color | Price | +-- +-------+---------+ +-- | Green | $170000 | +-- | Blue | $115000 | +-- | Green | $150000 | +-- +-------+---------+ + + +-- | A single column with a header. +headed :: c -> (a -> c) -> Colonnade Headed c a +headed h = singleton (Headed h) + +-- | A single column without a header. +headless :: (a -> c) -> Colonnade Headless c a +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 h = Colonnade . Vector.singleton . OneColonnade h + +-- | Lift a column over a 'Maybe'. For example, if some people +-- have houses and some do not, the data that pairs them together +-- could be represented as: +-- +-- >>> :{ +-- let owners :: [(Person,Maybe House)] +-- owners = +-- [ (Person "Jordan" 18, Nothing) +-- , (Person "Ruth" 25, Just (House Red 125000)) +-- , (Person "Sonia" 12, Just (House Green 145000)) +-- ] +-- :} +-- +-- The column encodings defined earlier can be reused with +-- the help of 'fromMaybe': +-- +-- >>> :{ +-- let encodingOwners :: Colonnade Headed String (Person,Maybe House) +-- encodingOwners = mconcat +-- [ contramap fst encodingPerson +-- , contramap snd (fromMaybe "" encodingHouse) +-- ] +-- :} +-- +-- >>> putStr (ascii encodingOwners owners) +-- +--------+-----+-------+---------+ +-- | Name | Age | Color | Price | +-- +--------+-----+-------+---------+ +-- | Jordan | 18 | | | +-- | Ruth | 25 | Red | $125000 | +-- | Sonia | 12 | Green | $145000 | +-- +--------+-----+-------+---------+ +fromMaybe :: c -> Colonnade f c a -> Colonnade f c (Maybe a) +fromMaybe c (Colonnade v) = Colonnade $ flip Vector.map v $ + \(OneColonnade h encode) -> OneColonnade h (maybe c encode) + +-- | Convert a collection of @b@ values into a columnar encoding of +-- the same size. Suppose we decide to show a house\'s color +-- by putting a check mark in the column corresponding to +-- the color instead of by writing out the name of the color: +-- +-- >>> 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 +-- >>> :t encHouse +-- encHouse :: Colonnade Headed [Char] House +-- >>> putStr (ascii encHouse houses) +-- +---------+-----+-------+------+ +-- | Price | Red | Green | Blue | +-- +---------+-----+-------+------+ +-- | $170000 | | ✓ | | +-- | $115000 | | | ✓ | +-- | $150000 | | ✓ | | +-- +---------+-----+-------+------+ +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 +columns getCell getHeader = id + . Colonnade + . Vector.map (\b -> OneColonnade (getHeader b) (getCell b)) + . Vector.fromList + . toList + +bool :: + f c -- ^ Heading + -> (a -> Bool) -- ^ Predicate + -> (a -> c) -- ^ Contents when predicate is false + -> (a -> c) -- ^ Contents when predicate is true + -> Colonnade f c a +bool h p onTrue onFalse = singleton h (Data.Bool.bool <$> onFalse <*> onTrue <*> p) + +replaceWhen :: + c + -> (a -> Bool) + -> Colonnade f c a + -> Colonnade f c a +replaceWhen newContent p (Colonnade v) = Colonnade + ( Vector.map + (\(OneColonnade h encode) -> OneColonnade h $ \a -> + if p a then newContent else encode a + ) 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 + +-- $render +-- +-- The rendering functions, which by convention begin with +-- the word @run@, are provided as a convenience for for +-- apply a columnar encoding. + + + +-- | Consider providing a variant the produces a list +-- instead. It may allow more things to get inlined +-- in to a loop. +runRow :: (c1 -> c2) -> Colonnade f c1 a -> a -> Vector c2 +runRow g (Colonnade v) a = flip Vector.map v $ + \(OneColonnade _ encode) -> g (encode a) + +runBothMonadic_ :: Monad m + => Colonnade Headed content a + -> (content -> content -> m b) + -> a + -> m () +runBothMonadic_ (Colonnade v) g a = + forM_ v $ \(OneColonnade (Headed h) encode) -> g h (encode a) + +runRowMonadic :: (Monad m, Monoid b) + => Colonnade f content a + -> (content -> m b) + -> a + -> m b +runRowMonadic (Colonnade v) g a = + flip foldlMapM v + $ \e -> g (oneColonnadeEncode e a) + +runRowMonadic_ :: Monad m + => Colonnade f content a + -> (content -> m b) + -> a + -> m () +runRowMonadic_ (Colonnade v) g a = + forM_ v $ \e -> g (oneColonnadeEncode e a) + +runRowMonadicWith :: (Monad m) + => b + -> (b -> b -> b) + -> Colonnade f content a + -> (content -> m b) + -> a + -> m b +runRowMonadicWith bempty bappend (Colonnade v) g a = + foldlM (\bl e -> do + br <- g (oneColonnadeEncode e a) + return (bappend bl br) + ) bempty v + +runHeader :: (c1 -> c2) -> Colonnade Headed c1 a -> Vector c2 +runHeader 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. +runHeaderMonadicGeneral :: (Monad m, Monoid b, Foldable h) + => Colonnade h content a + -> (content -> m b) + -> m b +runHeaderMonadicGeneral (Colonnade v) g = id + $ fmap (mconcat . Vector.toList) + $ Vector.mapM (foldlMapM g . oneColonnadeHead) v + +runHeaderMonadic :: (Monad m, Monoid b) + => Colonnade Headed content a + -> (content -> m b) + -> m b +runHeaderMonadic (Colonnade v) g = + fmap (mconcat . Vector.toList) $ Vector.mapM (g . getHeaded . oneColonnadeHead) v + +runHeaderMonadicGeneral_ :: (Monad m, Monoid b, Foldable h) + => Colonnade h content a + -> (content -> m b) + -> m () +runHeaderMonadicGeneral_ (Colonnade v) g = + Vector.mapM_ (foldlMapM g . oneColonnadeHead) v + +runHeaderMonadic_ :: + (Monad m) + => Colonnade Headed content a + -> (content -> m b) + -> m () +runHeaderMonadic_ (Colonnade v) g = Vector.mapM_ (g . getHeaded . oneColonnadeHead) v + +-- | 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 +-- code in the haddocks. +ascii :: Foldable f + => Colonnade Headed String a -- ^ columnar encoding + -> f a -- ^ rows + -> String +ascii enc xs = + let theHeader :: [(Int,String)] + theHeader = (zip (enumFrom 0) . map (\s -> " " ++ s ++ " ")) (toList (runHeader id enc)) + theBody :: [[(Int,String)]] + theBody = map (zip (enumFrom 0) . map (\s -> " " ++ s ++ " ") . toList . runRow 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 + ] + 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 + +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) + +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/Encoding.hs b/colonnade/src/Colonnade/Encoding.hs index 6de57c9..e69de29 100644 --- a/colonnade/src/Colonnade/Encoding.hs +++ b/colonnade/src/Colonnade/Encoding.hs @@ -1,347 +0,0 @@ --- | Build backend-agnostic columnar encodings that can be used to visualize data. - -module Colonnade.Encoding - ( -- * Example - -- $setup - -- * Create - headed - , headless - , singleton - -- * Transform - , fromMaybe - , columns - , bool - , replaceWhen - , mapContent - -- * Render - , runRow - , runRowMonadic - , runRowMonadic_ - , runRowMonadicWith - , runHeader - , runHeaderMonadic - , runHeaderMonadic_ - , runHeaderMonadicGeneral - , runHeaderMonadicGeneral_ - , runBothMonadic_ - -- * Ascii Table - , ascii - ) where - -import Colonnade.Types -import Data.Vector (Vector) -import Data.Foldable -import Data.Monoid (Endo(..)) -import Control.Monad -import Data.Functor.Contravariant -import qualified Data.Bool -import qualified Data.Maybe -import qualified Data.List as List -import qualified Data.Vector as Vector - --- $setup --- --- First, let\'s bring in some neccessary imports that will be --- used for the remainder of the examples in the docs: --- --- >>> import Data.Monoid (mconcat,(<>)) --- >>> import Data.Functor.Contravariant (contramap) --- --- Assume that the data we wish to encode is: --- --- >>> data Color = Red | Green | Blue deriving (Show,Eq) --- >>> data Person = Person { name :: String, age :: Int } --- >>> data House = House { color :: Color, price :: Int } --- --- One potential columnar encoding of a @Person@ would be: --- --- >>> :{ --- let encodingPerson :: Colonnade Headed String Person --- encodingPerson = mconcat --- [ headed "Name" name --- , headed "Age" (show . age) --- ] --- :} --- --- The type signature on @encodingPerson@ is not neccessary --- but is included for clarity. We can feed data into this encoding --- to build a table: --- --- >>> let people = [Person "David" 63, Person "Ava" 34, Person "Sonia" 12] --- >>> putStr (ascii encodingPerson people) --- +-------+-----+ --- | Name | Age | --- +-------+-----+ --- | David | 63 | --- | Ava | 34 | --- | Sonia | 12 | --- +-------+-----+ --- --- Similarly, we can build a table of houses with: --- --- >>> let showDollar = (('$':) . show) :: Int -> String --- >>> :{ --- let encodingHouse :: Colonnade Headed String House --- encodingHouse = mconcat --- [ headed "Color" (show . color) --- , headed "Price" (showDollar . price) --- ] --- :} --- --- >>> let houses = [House Green 170000, House Blue 115000, House Green 150000] --- >>> putStr (ascii encodingHouse houses) --- +-------+---------+ --- | Color | Price | --- +-------+---------+ --- | Green | $170000 | --- | Blue | $115000 | --- | Green | $150000 | --- +-------+---------+ - - --- | A single column with a header. -headed :: c -> (a -> c) -> Colonnade Headed c a -headed h = singleton (Headed h) - --- | A single column without a header. -headless :: (a -> c) -> Colonnade Headless c a -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 h = Colonnade . Vector.singleton . OneColonnade h - --- | Lift a column over a 'Maybe'. For example, if some people --- have houses and some do not, the data that pairs them together --- could be represented as: --- --- >>> :{ --- >>> let owners :: [(Person,Maybe House)] --- >>> owners = --- >>> [ (Person "Jordan" 18, Nothing) --- >>> , (Person "Ruth" 25, Just (House Red 125000)) --- >>> , (Person "Sonia" 12, Just (House Green 145000)) --- >>> ] --- >>> :} --- --- The column encodings defined earlier can be reused with --- the help of 'fromMaybe': --- --- >>> :{ --- >>> let encodingOwners :: Colonnade Headed String (Person,Maybe House) --- >>> encodingOwners = mconcat --- >>> [ contramap fst encodingPerson --- >>> , contramap snd (fromMaybe "" encodingHouse) --- >>> ] --- >>> :} --- --- >>> putStr (ascii encodingOwners owners) --- +--------+-----+-------+---------+ --- | Name | Age | Color | Price | --- +--------+-----+-------+---------+ --- | Jordan | 18 | | | --- | Ruth | 25 | Red | $125000 | --- | Sonia | 12 | Green | $145000 | --- +--------+-----+-------+---------+ -fromMaybe :: c -> Colonnade f c a -> Colonnade f c (Maybe a) -fromMaybe c (Colonnade v) = Colonnade $ flip Vector.map v $ - \(OneColonnade h encode) -> OneColonnade h (maybe c encode) - --- | Convert a collection of @b@ values into a columnar encoding of --- the same size. Suppose we decide to show a house\'s color --- by putting a check mark in the column corresponding to --- the color instead of by writing out the name of the color: --- --- >>> 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 --- >>> :t encHouse --- encHouse :: Colonnade Headed [Char] House --- >>> putStr (ascii encHouse houses) --- +---------+-----+-------+------+ --- | Price | Red | Green | Blue | --- +---------+-----+-------+------+ --- | $170000 | | ✓ | | --- | $115000 | | | ✓ | --- | $150000 | | ✓ | | --- +---------+-----+-------+------+ -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 -columns getCell getHeader = id - . Colonnade - . Vector.map (\b -> OneColonnade (getHeader b) (getCell b)) - . Vector.fromList - . toList - -bool :: - f c -- ^ Heading - -> (a -> Bool) -- ^ Predicate - -> (a -> c) -- ^ Contents when predicate is false - -> (a -> c) -- ^ Contents when predicate is true - -> Colonnade f c a -bool h p onTrue onFalse = singleton h (Data.Bool.bool <$> onFalse <*> onTrue <*> p) - -replaceWhen :: - c - -> (a -> Bool) - -> Colonnade f c a - -> Colonnade f c a -replaceWhen newContent p (Colonnade v) = Colonnade - ( Vector.map - (\(OneColonnade h encode) -> OneColonnade h $ \a -> - if p a then newContent else encode a - ) 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 - --- | Consider providing a variant the produces a list --- instead. It may allow more things to get inlined --- in to a loop. -runRow :: (c1 -> c2) -> Colonnade f c1 a -> a -> Vector c2 -runRow g (Colonnade v) a = flip Vector.map v $ - \(OneColonnade _ encode) -> g (encode a) - -runBothMonadic_ :: Monad m - => Colonnade Headed content a - -> (content -> content -> m b) - -> a - -> m () -runBothMonadic_ (Colonnade v) g a = - forM_ v $ \(OneColonnade (Headed h) encode) -> g h (encode a) - -runRowMonadic :: (Monad m, Monoid b) - => Colonnade f content a - -> (content -> m b) - -> a - -> m b -runRowMonadic (Colonnade v) g a = - flip foldlMapM v - $ \e -> g (oneColonnadeEncode e a) - -runRowMonadic_ :: Monad m - => Colonnade f content a - -> (content -> m b) - -> a - -> m () -runRowMonadic_ (Colonnade v) g a = - forM_ v $ \e -> g (oneColonnadeEncode e a) - -runRowMonadicWith :: (Monad m) - => b - -> (b -> b -> b) - -> Colonnade f content a - -> (content -> m b) - -> a - -> m b -runRowMonadicWith bempty bappend (Colonnade v) g a = - foldlM (\bl e -> do - br <- g (oneColonnadeEncode e a) - return (bappend bl br) - ) bempty v - -runHeader :: (c1 -> c2) -> Colonnade Headed c1 a -> Vector c2 -runHeader 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. -runHeaderMonadicGeneral :: (Monad m, Monoid b, Foldable h) - => Colonnade h content a - -> (content -> m b) - -> m b -runHeaderMonadicGeneral (Colonnade v) g = id - $ fmap (mconcat . Vector.toList) - $ Vector.mapM (foldlMapM g . oneColonnadeHead) v - -runHeaderMonadic :: (Monad m, Monoid b) - => Colonnade Headed content a - -> (content -> m b) - -> m b -runHeaderMonadic (Colonnade v) g = - fmap (mconcat . Vector.toList) $ Vector.mapM (g . getHeaded . oneColonnadeHead) v - -runHeaderMonadicGeneral_ :: (Monad m, Monoid b, Foldable h) - => Colonnade h content a - -> (content -> m b) - -> m () -runHeaderMonadicGeneral_ (Colonnade v) g = - Vector.mapM_ (foldlMapM g . oneColonnadeHead) v - -runHeaderMonadic_ :: - (Monad m) - => Colonnade Headed content a - -> (content -> m b) - -> m () -runHeaderMonadic_ (Colonnade v) g = Vector.mapM_ (g . getHeaded . oneColonnadeHead) v - --- | 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 --- code in the haddocks. -ascii :: Foldable f - => Colonnade Headed String a -- ^ columnar encoding - -> f a -- ^ rows - -> String -ascii enc xs = - let theHeader :: [(Int,String)] - theHeader = (zip (enumFrom 0) . map (\s -> " " ++ s ++ " ")) (toList (runHeader id enc)) - theBody :: [[(Int,String)]] - theBody = map (zip (enumFrom 0) . map (\s -> " " ++ s ++ " ") . toList . runRow 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 - ] - 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 - -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) - -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 new file mode 100644 index 0000000..4500b86 --- /dev/null +++ b/colonnade/src/Colonnade/Internal.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{-# OPTIONS_HADDOCK not-home #-} + +module Colonnade.Internal + ( Colonnade(..) + , OneColonnade(..) + , Headed(..) + , Headless(..) + ) where + +import Data.Vector (Vector) +import Data.Functor.Contravariant (Contravariant(..)) +import Data.Functor.Contravariant.Divisible (Divisible(..)) +import Control.Exception (Exception) +import Data.Typeable (Typeable) +import qualified Data.Vector as Vector + +-- | 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 +-- +-- The term @example@ represents a columnar encoding of @Foo@ +-- in which the columns have headings. +newtype Headed a = Headed { getHeaded :: a } + deriving (Eq,Ord,Functor,Show,Read,Foldable) + +-- | As the first argument to the 'Colonnade' type +-- constructor, this indictates that the columnar encoding does not have +-- a header. This type is isomorphic to 'Proxy' but is +-- given a new name to clarify its intent: +-- +-- > example :: Colonnade Headless Text Foo +-- +-- 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) + +instance Contravariant Headless where + contramap _ Headless = Headless + +-- | Encodes a header and a cell. +data OneColonnade f content a = OneColonnade + { oneColonnadeHead :: !(f content) + , oneColonnadeEncode :: !(a -> content) + } + +instance Contravariant (OneColonnade f content) where + contramap f (OneColonnade h e) = OneColonnade h (e . f) + +-- | An columnar encoding of @a@. The type variable @f@ determines what +-- is present in each column in the header row. It is typically instantiated +-- to 'Headed' and occasionally to 'Headless'. There is nothing that +-- restricts it to these two types, although they satisfy the majority +-- of use cases. The type variable @c@ is the content type. This can +-- be @Text@, @String@, or @ByteString@. In the companion libraries +-- @reflex-dom-colonnade@ and @yesod-colonnade@, additional types +-- that represent HTML with element attributes are provided that serve +-- as the content type. +-- +-- Internally, a 'Colonnade' is represented as a 'Vector' of individual +-- column encodings. It is possible to use any collection type with +-- 'Alternative' and 'Foldable' instances. However, 'Vector' was chosen to +-- optimize the data structure for the use case of building the structure +-- once and then folding over it many times. It is recommended that +-- 'Colonnade's are defined at the top-level so that GHC avoids reconstructing +-- them every time they are used. +newtype Colonnade f c a = Colonnade + { getColonnade :: Vector (OneColonnade f c a) + } deriving (Monoid) + +instance Contravariant (Colonnade f content) where + contramap f (Colonnade v) = Colonnade + (Vector.map (contramap f) v) + +instance Divisible (Colonnade f content) where + conquer = Colonnade Vector.empty + divide f (Colonnade a) (Colonnade b) = + Colonnade $ (Vector.++) + (Vector.map (contramap (fst . f)) a) + (Vector.map (contramap (snd . f)) b) + -- (Vector.map (\(OneEncoding h c) -> (h,c . fst . f)) a) + -- (Vector.map (\(OneEncoding h c) -> (h,c . snd . f)) b) + diff --git a/colonnade/test/Main.hs b/colonnade/test/Main.hs index 4da1ab0..940fb7d 100644 --- a/colonnade/test/Main.hs +++ b/colonnade/test/Main.hs @@ -2,5 +2,5 @@ import Test.DocTest main :: IO () main = doctest - [ "src/Colonnade/Encoding.hs" + [ "src/Colonnade.hs" ]