mirror of
https://github.com/byteverse/colonnade.git
synced 2024-09-11 06:45:41 +03:00
some changes
This commit is contained in:
parent
9a14ce158a
commit
5d268119ce
@ -301,40 +301,69 @@ builderCell = lazyTextCell . TBuilder.toLazyText
|
||||
-- used to add attributes to the generated @\<tr\>@ elements.
|
||||
encodeTable ::
|
||||
(Foldable f, Foldable h)
|
||||
=> Maybe Attribute -- ^ Attributes of @\<thead\>@, pass 'Nothing' to omit @\<thead\>@
|
||||
=> Maybe (Attribute,Attribute) -- ^ Attributes of @\<thead\>@ and its @\<tr\>@, pass 'Nothing' to omit @\<thead\>@
|
||||
-> Attribute -- ^ Attributes of @\<tbody\>@ element
|
||||
-> (a -> Attribute) -- ^ Attributes of each @\<tr\>@ element
|
||||
-> ((Html -> Html) -> c -> Html) -- ^ Wrap content and convert to 'Html'
|
||||
-> Attribute -- ^ Attributes of @\<table\>@ element
|
||||
-> Colonnade h c a -- ^ How to encode data as a row
|
||||
-> Colonnade h a c -- ^ How to encode data as a row
|
||||
-> f a -- ^ Collection of data
|
||||
-> Html
|
||||
encodeTable mtheadAttrs tbodyAttrs trAttrs wrapContent tableAttrs colonnade xs =
|
||||
H.table ! tableAttrs $ do
|
||||
for_ mtheadAttrs $ \theadAttrs -> do
|
||||
H.thead ! theadAttrs $ do
|
||||
for_ mtheadAttrs $ \(theadAttrs,theadTrAttrs) -> do
|
||||
H.thead ! theadAttrs $ H.tr ! theadTrAttrs $ do
|
||||
Encode.headerMonoidalGeneral colonnade (wrapContent H.th)
|
||||
H.tbody ! tbodyAttrs $ do
|
||||
forM_ xs $ \x -> do
|
||||
H.tr ! trAttrs x $ Encode.rowMonoidal colonnade (wrapContent H.td) x
|
||||
encodeBody trAttrs wrapContent tbodyAttrs colonnade xs
|
||||
|
||||
encodeTieredHeaderTable :: Foldable f
|
||||
=> Attribute -- ^ Attributes of @\<thead\>@
|
||||
-> Attribute -- ^ Attributes of @\<tbody\>@ element
|
||||
-> (a -> Attribute) -- ^ Attributes of each @\<tr\>@ element in the @\<tbody\>@
|
||||
-> ((Html -> Html) -> c -> Html) -- ^ Wrap content and convert to 'Html'
|
||||
-> Attribute -- ^ Attributes of @\<table\>@ element
|
||||
-> Fascia p Attribute -- ^ Attributes for @\<tr\>@ elements in the @\<thead\>@
|
||||
-> Cornice p a c
|
||||
-> f a -- ^ Collection of data
|
||||
-> Html
|
||||
encodeTieredHeaderTable theadAttrs tbodyAttrs trAttrs wrapContent tableAttrs cornice xs = do
|
||||
let colonnade = CE.discard cornice
|
||||
annCornice = annotate cornice
|
||||
H.table ! tableAttrs $ do
|
||||
H.thead ! theadAttrs $ H.tr ! trAttrs $ do
|
||||
Encode.headerMonoidalGeneral colonnade (wrapContent H.th)
|
||||
encodeBody trAttrs wrapContent tbodyAttrs colonnade xs
|
||||
|
||||
encodeBody :: (Foldable h, Foldable f)
|
||||
=> (a -> Attribute) -- ^ Attributes of each @\<tr\>@ element
|
||||
-> ((Html -> Html) -> c -> Html) -- ^ Wrap content and convert to 'Html'
|
||||
-> Attribute -- ^ Attributes of @\<tbody\>@ element
|
||||
-> Colonnade h a c -- ^ How to encode data as a row
|
||||
-> f a -- ^ Collection of data
|
||||
-> Html
|
||||
encodeBody trAttrs wrapContent tbodyAttrs colonnade xs = do
|
||||
H.tbody ! tbodyAttrs $ do
|
||||
forM_ xs $ \x -> do
|
||||
H.tr ! trAttrs x $ Encode.rowMonoidal colonnade (wrapContent H.td) x
|
||||
|
||||
|
||||
-- | Encode a table with a header. Table cells may have attributes
|
||||
-- applied to them.
|
||||
encodeHeadedCellTable ::
|
||||
Foldable f
|
||||
=> Attribute -- ^ Attributes of @\<table\>@ element
|
||||
-> Colonnade Headed Cell a -- ^ How to encode data as columns
|
||||
-> Colonnade Headed a Cell -- ^ How to encode data as columns
|
||||
-> f a -- ^ Collection of data
|
||||
-> Html
|
||||
encodeHeadedCellTable = encodeTable
|
||||
(Just mempty) mempty (const mempty) htmlFromCell
|
||||
(Just (mempty,mempty)) mempty (const mempty) htmlFromCell
|
||||
|
||||
-- | Encode a table without a header. Table cells may have attributes
|
||||
-- applied to them.
|
||||
encodeHeadlessCellTable ::
|
||||
Foldable f
|
||||
=> Attribute -- ^ Attributes of @\<table\>@ element
|
||||
-> Colonnade Headless Cell a -- ^ How to encode data as columns
|
||||
-> Colonnade Headless a Cell -- ^ How to encode data as columns
|
||||
-> f a -- ^ Collection of data
|
||||
-> Html
|
||||
encodeHeadlessCellTable = encodeTable
|
||||
@ -345,18 +374,18 @@ encodeHeadlessCellTable = encodeTable
|
||||
encodeHeadedHtmlTable ::
|
||||
Foldable f
|
||||
=> Attribute -- ^ Attributes of @\<table\>@ element
|
||||
-> Colonnade Headed Html a -- ^ How to encode data as columns
|
||||
-> Colonnade Headed a Html -- ^ How to encode data as columns
|
||||
-> f a -- ^ Collection of data
|
||||
-> Html
|
||||
encodeHeadedHtmlTable = encodeTable
|
||||
(Just mempty) mempty (const mempty) ($)
|
||||
(Just (mempty,mempty)) mempty (const mempty) ($)
|
||||
|
||||
-- | Encode a table without a header. Table cells cannot have attributes
|
||||
-- applied to them.
|
||||
encodeHeadlessHtmlTable ::
|
||||
Foldable f
|
||||
=> Attribute -- ^ Attributes of @\<table\>@ element
|
||||
-> Colonnade Headless Html a -- ^ How to encode data as columns
|
||||
-> Colonnade Headless a Html -- ^ How to encode data as columns
|
||||
-> f a -- ^ Collection of data
|
||||
-> Html
|
||||
encodeHeadlessHtmlTable = encodeTable
|
||||
|
@ -31,6 +31,7 @@ library
|
||||
Colonnade
|
||||
Colonnade.Encode
|
||||
Colonnade.Internal
|
||||
Colonnade.Cornice.Encode
|
||||
build-depends:
|
||||
base >= 4.7 && < 5
|
||||
, contravariant >= 1.2 && < 1.5
|
||||
|
@ -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
|
||||
|
203
colonnade/src/Colonnade/Cornice/Encode.hs
Normal file
203
colonnade/src/Colonnade/Cornice/Encode.hs
Normal file
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
||||
|
||||
|
@ -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
|
||||
|
||||
|
@ -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.
|
||||
|
Loading…
Reference in New Issue
Block a user