work in progress
This commit is contained in:
Andrew Martin
parent
2209ed7162
commit
75b2431b5c
@ -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
|
||||
|
||||
361
colonnade/src/Colonnade.hs
Normal file
361
colonnade/src/Colonnade.hs
Normal file
@ -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
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
90
colonnade/src/Colonnade/Internal.hs
Normal file
90
colonnade/src/Colonnade/Internal.hs
Normal file
@ -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)
|
||||
|
||||
@ -2,5 +2,5 @@ import Test.DocTest
|
||||
|
||||
main :: IO ()
|
||||
main = doctest
|
||||
[ "src/Colonnade/Encoding.hs"
|
||||
[ "src/Colonnade.hs"
|
||||
]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user