colonnade 0.4.7 → 1.2.0.2
raw patch · 12 files changed
Files
- colonnade.cabal +44/−27
- src/Colonnade.hs +438/−0
- src/Colonnade/Decoding.hs +0/−160
- src/Colonnade/Decoding/ByteString/Char8.hs +0/−26
- src/Colonnade/Decoding/Text.hs +0/−47
- src/Colonnade/Encode.hs +691/−0
- src/Colonnade/Encoding.hs +0/−343
- src/Colonnade/Encoding/ByteString/Char8.hs +0/−24
- src/Colonnade/Encoding/Text.hs +0/−24
- src/Colonnade/Internal.hs +0/−23
- src/Colonnade/Types.hs +0/−152
- test/Main.hs +1/−1
colonnade.cabal view
@@ -1,45 +1,62 @@-name: colonnade-version: 0.4.7-synopsis: Generic types and functions for columnar encoding and decoding-description: Please see README.md-homepage: https://github.com/andrewthad/colonnade#readme-license: BSD3-license-file: LICENSE-author: Andrew Martin-maintainer: andrew.thaddeus@gmail.com-copyright: 2016 Andrew Martin-category: web-build-type: Simple-cabal-version: >=1.10+name: colonnade+version: 1.2.0.2+synopsis: Generic types and functions for columnar encoding and decoding+description:+ The `colonnade` package provides a way to talk about+ columnar encodings and decodings of data. This package provides+ very general types and does not provide a way for the end-user+ to actually apply the columnar encodings they build to data.+ Most users will also want to one a companion packages+ that provides (1) a content type and (2) functions for feeding+ data into a columnar encoding:+ .+ * <https://hackage.haskell.org/package/lucid-colonnade lucid-colonnade> for `lucid` html tables+ .+ * <https://hackage.haskell.org/package/blaze-colonnade blaze-colonnade> for `blaze` html tables+ .+ * <https://hackage.haskell.org/package/reflex-dom-colonnade reflex-dom-colonnade> for reactive `reflex-dom` tables+ .+ * <https://hackage.haskell.org/package/yesod-colonnade yesod-colonnade> for `yesod` widgets+ .+ * <http://hackage.haskell.org/package/siphon siphon> for encoding and decoding CSVs+homepage: https://github.com/andrewthad/colonnade#readme+license: BSD3+license-file: LICENSE+author: Andrew Martin+maintainer: andrew.thaddeus@gmail.com+copyright: 2016 Andrew Martin+category: web+build-type: Simple+cabal-version: >=1.10 library hs-source-dirs: src exposed-modules:- Colonnade.Types- Colonnade.Encoding- Colonnade.Encoding.Text- Colonnade.Encoding.ByteString.Char8- Colonnade.Decoding- Colonnade.Decoding.Text- Colonnade.Decoding.ByteString.Char8- Colonnade.Internal+ Colonnade+ Colonnade.Encode build-depends:- base >= 4.7 && < 5- , contravariant >= 1.2 && < 1.5- , vector >= 0.10 && < 0.12+ base >= 4.8 && < 5+ , contravariant >= 1.2 && < 1.6+ , vector >= 0.10 && < 0.13 , text >= 1.0 && < 1.3 , bytestring >= 0.10 && < 0.11+ , profunctors >= 5.0 && < 5.4+ , semigroups >= 0.18.2 && < 0.20 default-language: Haskell2010 ghc-options: -Wall test-suite test- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: Main.hs+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs build-depends: base >= 4.7 && <= 5 , colonnade , doctest+ , semigroupoids+ , ansi-wl-pprint+ , QuickCheck+ , fast-logger default-language: Haskell2010 source-repository head
+ src/Colonnade.hs view
@@ -0,0 +1,438 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RankNTypes #-}++{-# OPTIONS_GHC -Wall -fno-warn-unused-imports -fno-warn-unticked-promoted-constructors #-}++-- | Build backend-agnostic columnar encodings that can be +-- used to visualize tabular data.+module Colonnade+ ( -- * Example+ -- $setup+ -- * Types+ Colonnade+ , Headed(..)+ , Headless(..)+ -- * Typeclasses+ , E.Headedness(..)+ -- * Create+ , headed+ , headless+ , singleton+ -- * Transform+ -- ** Body+ , fromMaybe+ , columns+ , bool+ , replaceWhen+ , modifyWhen+ -- ** Header+ , mapHeaderContent+ , mapHeadedness+ , toHeadless+ -- * Cornice+ -- ** Types+ , Cornice+ , Pillar(..)+ , Fascia(..)+ -- ** Create+ , cap+ , recap+ -- * Ascii Table+ , ascii+ , asciiCapped+ ) where++import Colonnade.Encode (Colonnade,Cornice,+ Pillar(..),Fascia(..),Headed(..),Headless(..))+import Data.Foldable+import Control.Monad+import qualified Data.Bool+import qualified Data.Maybe+import qualified Colonnade.Encode as E+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.Profunctor (lmap)+--+-- The data types we wish to encode are:+--+-- >>> 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 colPerson :: Colonnade Headed Person String+-- colPerson = mconcat+-- [ headed "Name" name+-- , headed "Age" (show . age)+-- ]+-- :}+--+-- The type signature on @colPerson@ 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 colPerson people)+-- +-------+-----++-- | Name | Age |+-- +-------+-----++-- | David | 63 |+-- | Ava | 34 |+-- | Sonia | 12 |+-- +-------+-----++--+-- Similarly, we can build a table of houses with:+--+-- >>> let showDollar = (('$':) . show) :: Int -> String+-- >>> colHouse = mconcat [headed "Color" (show . color), headed "Price" (showDollar . price)]+-- >>> :t colHouse+-- colHouse :: Colonnade Headed House [Char]+-- >>> let houses = [House Green 170000, House Blue 115000, House Green 150000]+-- >>> putStr (ascii colHouse houses)+-- +-------+---------++-- | Color | Price |+-- +-------+---------++-- | Green | $170000 |+-- | Blue | $115000 |+-- | Green | $150000 |+-- +-------+---------++++-- | A single column with a header.+headed :: c -> (a -> c) -> Colonnade Headed a c+headed h = singleton (Headed h)++-- | A single column without a header.+headless :: (a -> c) -> Colonnade Headless a c+headless = singleton Headless++-- | A single column with any kind of header. This is not typically needed.+singleton :: h c -> (a -> c) -> Colonnade h a c+singleton h = E.Colonnade . Vector.singleton . E.OneColonnade h++-- | Map over the content in the header. This is similar performing 'fmap'+-- on a 'Colonnade' except that the body content is unaffected.+mapHeaderContent :: Functor h => (c -> c) -> Colonnade h a c -> Colonnade h a c+mapHeaderContent f (E.Colonnade v) = + E.Colonnade (Vector.map (\(E.OneColonnade h e) -> E.OneColonnade (fmap f h) e) v)++-- | Map over the header type of a 'Colonnade'.+mapHeadedness :: (forall x. h x -> h' x) -> Colonnade h a c -> Colonnade h' a c+mapHeadedness f (E.Colonnade v) =+ E.Colonnade (Vector.map (\(E.OneColonnade h e) -> E.OneColonnade (f h) e) v)++-- | Remove the heading from a 'Colonnade'.+toHeadless :: Colonnade h a c -> Colonnade Headless a c+toHeadless = mapHeadedness (const Headless)+ ++-- | 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 colOwners :: Colonnade Headed (Person,Maybe House) String+-- colOwners = mconcat+-- [ lmap fst colPerson+-- , lmap snd (fromMaybe "" colHouse)+-- ]+-- :}+--+-- >>> putStr (ascii colOwners owners)+-- +--------+-----+-------+---------++-- | Name | Age | Color | Price |+-- +--------+-----+-------+---------++-- | Jordan | 18 | | |+-- | Ruth | 25 | Red | $125000 |+-- | Sonia | 12 | Green | $145000 |+-- +--------+-----+-------+---------++fromMaybe :: c -> Colonnade f a c -> Colonnade f (Maybe a) c+fromMaybe c (E.Colonnade v) = E.Colonnade $ flip Vector.map v $+ \(E.OneColonnade h encode) -> E.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 Color [Char]+-- >>> let encHouse = headed "Price" (showDollar . price) <> lmap color encColor+-- >>> :t encHouse+-- encHouse :: Colonnade Headed House [Char]+-- >>> 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 a c+columns getCell getHeader = id+ . E.Colonnade+ . Vector.map (\b -> E.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 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+-- given predicate. Header content is unaffected. With an HTML backend, +-- this can be used to strikethrough the contents of cells with data that is+-- considered invalid.+modifyWhen ::+ (c -> c) -- ^ Content change+ -> (a -> Bool) -- ^ Row predicate+ -> Colonnade f a c -- ^ Original 'Colonnade'+ -> Colonnade f a c+modifyWhen changeContent p (E.Colonnade v) = E.Colonnade+ ( Vector.map+ (\(E.OneColonnade h encode) -> E.OneColonnade h $ \a ->+ if p a then changeContent (encode a) else encode a+ ) v+ )++-- | Replace the contents of cells in rows whose values satisfy the+-- given predicate. Header content is unaffected.+replaceWhen ::+ c -- ^ New content+ -> (a -> Bool) -- ^ Row predicate+ -> Colonnade f a c -- ^ Original 'Colonnade'+ -> Colonnade f a c+replaceWhen = modifyWhen . const++-- | Augment a 'Colonnade' with a header spans over all of the+-- existing headers. This is best demonstrated by example. +-- Let\'s consider how we might encode a pairing of the people +-- and houses from the initial example:+-- +-- >>> let personHomePairs = zip people houses+-- >>> let colPersonFst = lmap fst colPerson+-- >>> let colHouseSnd = lmap snd colHouse+-- >>> putStr (ascii (colPersonFst <> colHouseSnd) personHomePairs)+-- +-------+-----+-------+---------++-- | Name | Age | Color | Price |+-- +-------+-----+-------+---------++-- | David | 63 | Green | $170000 |+-- | Ava | 34 | Blue | $115000 |+-- | Sonia | 12 | Green | $150000 |+-- +-------+-----+-------+---------++-- +-- This tabular encoding leaves something to be desired. The heading+-- not indicate that the name and age refer to a person and that+-- the color and price refer to a house. Without reaching for 'Cornice',+-- we can still improve this situation with 'mapHeaderContent':+--+-- >>> let colPersonFst' = mapHeaderContent ("Person " ++) colPersonFst+-- >>> let colHouseSnd' = mapHeaderContent ("House " ++) colHouseSnd+-- >>> putStr (ascii (colPersonFst' <> colHouseSnd') personHomePairs)+-- +-------------+------------+-------------+-------------++-- | Person Name | Person Age | House Color | House Price |+-- +-------------+------------+-------------+-------------++-- | David | 63 | Green | $170000 |+-- | Ava | 34 | Blue | $115000 |+-- | Sonia | 12 | Green | $150000 |+-- +-------------+------------+-------------+-------------++--+-- This is much better, but for longer tables, the redundancy+-- of prefixing many column headers can become annoying. The solution+-- that a 'Cornice' offers is to nest headers:+-- +-- >>> let cor = mconcat [cap "Person" colPersonFst, cap "House" colHouseSnd]+-- >>> :t cor+-- cor :: Cornice Headed ('Cap 'Base) (Person, House) [Char]+-- >>> putStr (asciiCapped cor personHomePairs)+-- +-------------+-----------------++-- | Person | House |+-- +-------+-----+-------+---------++-- | Name | Age | Color | Price |+-- +-------+-----+-------+---------++-- | David | 63 | Green | $170000 |+-- | Ava | 34 | Blue | $115000 |+-- | Sonia | 12 | Green | $150000 |+-- +-------+-----+-------+---------++-- +cap :: c -> Colonnade h a c -> Cornice h (Cap Base) a c+cap h = E.CorniceCap . Vector.singleton . E.OneCornice h . E.CorniceBase++-- | Add another cap to a cornice. There is no limit to how many times+-- this can be applied:+-- +-- >>> data Day = Weekday | Weekend deriving (Show)+-- >>> :{+-- let cost :: Int -> Day -> String+-- cost base w = case w of+-- Weekday -> showDollar base+-- Weekend -> showDollar (base + 1)+-- colStandard = foldMap (\c -> headed c (cost 8)) ["Yt","Ad","Sr"]+-- colSpecial = mconcat [headed "Stud" (cost 6), headed "Mltry" (cost 7)]+-- corStatus = mconcat+-- [ cap "Standard" colStandard+-- , cap "Special" colSpecial+-- ] +-- corShowtime = mconcat+-- [ recap "" (cap "" (headed "Day" show))+-- , foldMap (\c -> recap c corStatus) ["Matinee","Evening"]+-- ]+-- :}+--+-- >>> putStr (asciiCapped corShowtime [Weekday,Weekend])+-- +---------+-----------------------------+-----------------------------++-- | | Matinee | Evening |+-- +---------+--------------+--------------+--------------+--------------++-- | | Standard | Special | Standard | Special |+-- +---------+----+----+----+------+-------+----+----+----+------+-------++-- | Day | Yt | Ad | Sr | Stud | Mltry | Yt | Ad | Sr | Stud | Mltry |+-- +---------+----+----+----+------+-------+----+----+----+------+-------++-- | Weekday | $8 | $8 | $8 | $6 | $7 | $8 | $8 | $8 | $6 | $7 |+-- | Weekend | $9 | $9 | $9 | $7 | $8 | $9 | $9 | $9 | $7 | $8 |+-- +---------+----+----+----+------+-------+----+----+----+------+-------++recap :: c -> Cornice h p a c -> Cornice h (Cap p) a c+recap h cor = E.CorniceCap (Vector.singleton (E.OneCornice h cor))++asciiCapped :: Foldable f+ => Cornice Headed p a String -- ^ columnar encoding+ -> f a -- ^ rows+ -> String+asciiCapped cor xs =+ let annCor = E.annotateFinely (\x y -> x + y + 3) id + List.length xs cor+ sizedCol = E.uncapAnnotated annCor+ in E.headersMonoidal+ Nothing + [ ( \msz _ -> case msz of+ Just sz -> "+" ++ hyphens (sz + 2)+ Nothing -> ""+ , \s -> s ++ "+\n"+ )+ , ( \msz c -> case msz of+ Just sz -> "| " ++ rightPad sz ' ' c ++ " "+ Nothing -> ""+ , \s -> s ++ "|\n"+ )+ ] annCor ++ asciiBody sizedCol xs+ ++-- | 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 example+-- code in the haddocks.+ascii :: Foldable f+ => Colonnade Headed a String -- ^ columnar encoding+ -> f a -- ^ rows+ -> String+ascii col xs = + let sizedCol = E.sizeColumns List.length xs col+ divider = concat+ [ E.headerMonoidalFull sizedCol + (\(E.Sized msz _) -> case msz of+ Just sz -> "+" ++ hyphens (sz + 2)+ Nothing -> ""+ )+ , "+\n"+ ]+ in List.concat+ [ divider+ , concat+ [ E.headerMonoidalFull sizedCol+ (\(E.Sized msz (Headed h)) -> case msz of+ Just sz -> "| " ++ rightPad sz ' ' h ++ " "+ Nothing -> ""+ )+ , "|\n"+ ]+ , asciiBody sizedCol xs+ ]++asciiBody :: Foldable f+ => Colonnade (E.Sized (Maybe Int) Headed) a String+ -> f a+ -> String+asciiBody sizedCol xs =+ let divider = concat+ [ E.headerMonoidalFull sizedCol + (\(E.Sized msz _) -> case msz of+ Just sz -> "+" ++ hyphens (sz + 2)+ Nothing -> ""+ )+ , "+\n"+ ]+ rowContents = foldMap+ (\x -> concat+ [ E.rowMonoidalHeader + sizedCol+ (\(E.Sized msz _) c -> case msz of+ Nothing -> ""+ Just sz -> "| " ++ rightPad sz ' ' c ++ " "+ )+ x+ , "|\n"+ ]+ ) xs+ in List.concat+ [ 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++-- data Company = Company String String Int+-- +-- data Company = Company+-- { companyName :: String+-- , companyCountry :: String+-- , companyValue :: Int+-- } deriving (Show)+-- +-- myCompanies :: [Company]+-- myCompanies =+-- [ Company "eCommHub" "United States" 50+-- , Company "Layer 3 Communications" "United States" 10000000+-- , Company "Microsoft" "England" 500000000+-- ]++++++
− src/Colonnade/Decoding.hs
@@ -1,160 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE BangPatterns #-}-module Colonnade.Decoding where--import Colonnade.Internal (EitherWrap(..),mapLeft)-import Colonnade.Types-import Data.Functor.Contravariant-import Data.Vector (Vector)-import qualified Data.Vector as Vector-import Data.Char (chr)---- | Converts the content type of a 'Decoding'. The @'Contravariant' f@--- constraint means that @f@ can be 'Headless' but not 'Headed'.-contramapContent :: forall c1 c2 f a. Contravariant f => (c2 -> c1) -> Decoding f c1 a -> Decoding f c2 a-contramapContent f = go- where- go :: forall b. Decoding f c1 b -> Decoding f c2 b- go (DecodingPure x) = DecodingPure x- go (DecodingAp h decode apNext) =- DecodingAp (contramap f h) (decode . f) (go apNext)--headless :: (content -> Either String a) -> Decoding Headless content a-headless f = DecodingAp Headless f (DecodingPure id)--headed :: content -> (content -> Either String a) -> Decoding Headed content a-headed h f = DecodingAp (Headed h) f (DecodingPure id)--indexed :: Int -> (content -> Either String a) -> Decoding (Indexed Headless) content a-indexed ix f = DecodingAp (Indexed ix Headless) f (DecodingPure id)--maxIndex :: forall f c a. Decoding (Indexed f) c a -> Int-maxIndex = go 0 where- go :: forall b. Int -> Decoding (Indexed f) c b -> Int- go !ix (DecodingPure _) = ix- go !ix1 (DecodingAp (Indexed ix2 _) decode apNext) =- go (max ix1 ix2) apNext---- | This function uses 'unsafeIndex' to access--- elements of the 'Vector'.-uncheckedRunWithRow ::- Int- -> Decoding (Indexed f) content a- -> Vector content- -> Either (DecodingRowError f content) a-uncheckedRunWithRow i d v = mapLeft (DecodingRowError i . RowErrorDecode) (uncheckedRun d v)---- | This function does not check to make sure that the indicies in--- the 'Decoding' are in the 'Vector'.-uncheckedRun :: forall content a f.- Decoding (Indexed f) content a- -> Vector content- -> Either (DecodingCellErrors f content) a-uncheckedRun dc v = getEitherWrap (go dc)- where- go :: forall b.- Decoding (Indexed f) content b- -> EitherWrap (DecodingCellErrors f content) b- go (DecodingPure b) = EitherWrap (Right b)- go (DecodingAp ixed@(Indexed ix h) decode apNext) =- let rnext = go apNext- content = Vector.unsafeIndex v ix- rcurrent = mapLeft (DecodingCellErrors . Vector.singleton . DecodingCellError content ixed) (decode content)- in rnext <*> (EitherWrap rcurrent)--headlessToIndexed :: forall c a.- Decoding Headless c a -> Decoding (Indexed Headless) c a-headlessToIndexed = go 0 where- go :: forall b. Int -> Decoding Headless c b -> Decoding (Indexed Headless) c b- go !ix (DecodingPure a) = DecodingPure a- go !ix (DecodingAp Headless decode apNext) =- DecodingAp (Indexed ix Headless) decode (go (ix + 1) apNext)--length :: forall f c a. Decoding f c a -> Int-length = go 0 where- go :: forall b. Int -> Decoding f c b -> Int- go !a (DecodingPure _) = a- go !a (DecodingAp _ _ apNext) = go (a + 1) apNext---- | Maps over a 'Decoding' that expects headers, converting these--- expected headers into the indices of the columns that they--- correspond to.-headedToIndexed :: forall content a. Eq content- => Vector content -- ^ Headers in the source document- -> Decoding Headed content a -- ^ Decoding that contains expected headers- -> Either (HeadingErrors content) (Decoding (Indexed Headed) content a)-headedToIndexed v = getEitherWrap . go- where- go :: forall b. Eq content- => Decoding Headed content b- -> EitherWrap (HeadingErrors content) (Decoding (Indexed Headed) content b)- go (DecodingPure b) = EitherWrap (Right (DecodingPure b))- go (DecodingAp hd@(Headed h) decode apNext) =- let rnext = go apNext- ixs = Vector.elemIndices h v- ixsLen = Vector.length ixs- rcurrent- | ixsLen == 1 = Right (Vector.unsafeIndex ixs 0)- | ixsLen == 0 = Left (HeadingErrors (Vector.singleton h) Vector.empty)- | otherwise = Left (HeadingErrors Vector.empty (Vector.singleton (h,ixsLen)))- in (\ix ap -> DecodingAp (Indexed ix hd) decode ap)- <$> EitherWrap rcurrent- <*> rnext---- | This adds one to the index because text editors consider--- line number to be one-based, not zero-based.-prettyError :: (c -> String) -> DecodingRowError f c -> String-prettyError toStr (DecodingRowError ix e) = unlines- $ ("Decoding error on line " ++ show (ix + 1) ++ " of file.")- : ("Error Category: " ++ descr)- : map (" " ++) errDescrs- where (descr,errDescrs) = prettyRowError toStr e--prettyRowError :: (content -> String) -> RowError f content -> (String, [String])-prettyRowError toStr x = case x of- RowErrorParse err -> (,) "CSV Parsing"- [ "The line could not be parsed into cells correctly."- , "Original parser error: " ++ err- ]- RowErrorSize reqLen actualLen -> (,) "Row Length"- [ "Expected the row to have exactly " ++ show reqLen ++ " cells."- , "The row only has " ++ show actualLen ++ " cells."- ]- RowErrorMinSize reqLen actualLen -> (,) "Row Min Length"- [ "Expected the row to have at least " ++ show reqLen ++ " cells."- , "The row only has " ++ show actualLen ++ " cells."- ]- RowErrorMalformed enc -> (,) "Text Decoding"- [ "Tried to decode the input as " ++ enc ++ " text"- , "There is a mistake in the encoding of the text."- ]- RowErrorHeading errs -> (,) "Header" (prettyHeadingErrors toStr errs)- RowErrorDecode errs -> (,) "Cell Decoding" (prettyCellErrors toStr errs)--prettyCellErrors :: (c -> String) -> DecodingCellErrors f c -> [String]-prettyCellErrors toStr (DecodingCellErrors errs) = drop 1 $- flip concatMap errs $ \(DecodingCellError content (Indexed ix _) msg) ->- let str = toStr content in- [ "-----------"- , "Column " ++ columnNumToLetters ix- , "Original parse error: " ++ msg- , "Cell Content Length: " ++ show (Prelude.length str)- , "Cell Content: " ++ if null str- then "[empty cell]"- else str- ]--prettyHeadingErrors :: (c -> String) -> HeadingErrors c -> [String]-prettyHeadingErrors conv (HeadingErrors missing duplicates) = concat- [ concatMap (\h -> ["The header " ++ conv h ++ " was missing."]) missing- , concatMap (\(h,n) -> ["The header " ++ conv h ++ " occurred " ++ show n ++ " times."]) duplicates- ]--columnNumToLetters :: Int -> String-columnNumToLetters i- | i >= 0 && i < 25 = [chr (i + 65)]- | otherwise = "Beyond Z. Fix this."---
− src/Colonnade/Decoding/ByteString/Char8.hs
@@ -1,26 +0,0 @@-module Colonnade.Decoding.ByteString.Char8 where--import Data.ByteString (ByteString)-import qualified Data.ByteString as ByteString-import qualified Data.ByteString.Char8 as BC8--char :: ByteString -> Either String Char-char b = case BC8.length b of- 1 -> Right (BC8.head b)- 0 -> Left "cannot decode Char from empty bytestring"- _ -> Left "cannot decode Char from multi-character bytestring"--int :: ByteString -> Either String Int-int b = do- (a,bsRem) <- maybe (Left "could not parse int") Right (BC8.readInt b)- if ByteString.null bsRem- then Right a- else Left "found extra characters after int"--bool :: ByteString -> Either String Bool-bool b- | b == BC8.pack "true" = Right True- | b == BC8.pack "false" = Right False- | otherwise = Left "must be true or false"--
− src/Colonnade/Decoding/Text.hs
@@ -1,47 +0,0 @@-module Colonnade.Decoding.Text where--import Prelude hiding (map)-import Data.Text (Text)-import qualified Data.Text as Text-import qualified Data.Text.Read as TextRead--char :: Text -> Either String Char-char t = case Text.length t of- 1 -> Right (Text.head t)- 0 -> Left "cannot decode Char from empty text"- _ -> Left "cannot decode Char from multi-character text"--text :: Text -> Either String Text-text = Right--int :: Text -> Either String Int-int t = do- (a,tRem) <- TextRead.decimal t- if Text.null tRem- then Right a- else Left "found extra characters after int"--trueFalse :: Text -> Text -> Text -> Either String Bool-trueFalse t f txt- | txt == t = Right True- | txt == f = Right False- | otherwise = Left $ concat- ["must be [", Text.unpack t, "] or [", Text.unpack f, "]"]---- | This refers to the 'TextRead.Reader' from @Data.Text.Read@, not--- to the @Reader@ monad.-fromReader :: TextRead.Reader a -> Text -> Either String a-fromReader f t = do- (a,tRem) <- f t- if Text.null tRem- then Right a- else Left "found extra characters at end of text"--optional :: (Text -> Either String a) -> Text -> Either String (Maybe a)-optional f t = if Text.null t- then Right Nothing- else fmap Just (f t)--map :: (a -> b) -> (Text -> Either String a) -> Text -> Either String b-map f g t = fmap f (g t)-
+ src/Colonnade/Encode.hs view
@@ -0,0 +1,691 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_HADDOCK not-home #-}+{-# OPTIONS_GHC -Wall -fno-warn-unused-imports -fno-warn-unticked-promoted-constructors #-}++-- | Most users of this library do not need this module. The functions+-- here are used to build functions that apply a 'Colonnade'+-- to a collection of values, building a table from them. Ultimately, +-- a function that applies a @Colonnade Headed MyCell a@ +-- to data will have roughly the following type:+--+-- > myTableRenderer :: Foldable g => Colonnade Headed MyCell a -> g a -> MyContent+--+-- In the companion packages @yesod-colonnade@ and+-- @reflex-dom-colonnade@, functions with+-- similar type signatures are readily available.+-- These packages use the functions provided here+-- in the implementations of their rendering functions.+-- It is recommended that users who believe they may need+-- this module look at the source of the companion packages +-- to see an example of how this module\'s functions are used.+-- Other backends are encouraged to use these functions+-- to build monadic or monoidal content from a 'Colonnade'.+--+-- The functions exported here take a 'Colonnade' and +-- convert it to a fragment of content. The functions whose+-- names start with @row@ take at least a @Colonnade f c a@ and an @a@+-- value to generate a row of content. The functions whose names+-- start with @header@ need the @Colonnade f c a@ but not+-- an @a@ value since a value is not needed to build a header.+-- +module Colonnade.Encode+ ( -- * Colonnade+ -- ** Types+ Colonnade(..)+ , OneColonnade(..)+ , Headed(..)+ , Headless(..)+ , Sized(..)+ , ExtractForall(..)+ -- ** Typeclasses+ , Headedness(..)+ -- ** Row+ , row+ , rowMonadic+ , rowMonadic_+ , rowMonadicWith+ , rowMonoidal+ , rowMonoidalHeader+ -- ** Header+ , header+ , headerMonadic+ , headerMonadic_+ , headerMonadicGeneral+ , headerMonadicGeneral_+ , headerMonoidalGeneral+ , headerMonoidalFull+ -- ** Other+ , bothMonadic_+ , sizeColumns+ -- * Cornice+ -- ** Types+ , Cornice(..)+ , AnnotatedCornice(..)+ , OneCornice(..)+ , Pillar(..)+ , ToEmptyCornice(..)+ , Fascia(..)+ -- ** Encoding+ , annotate+ , annotateFinely+ , size+ , endow+ , discard+ , headersMonoidal+ , uncapAnnotated+ ) where++import Data.Vector (Vector)+import Data.Foldable+import Control.Monad.ST (ST,runST)+import Data.Monoid+import Data.Functor.Contravariant (Contravariant(..))+import Data.Profunctor (Profunctor(..))+import Data.Semigroup (Semigroup)+import Data.List.NonEmpty (NonEmpty((:|)))+import Data.Foldable (toList)+import qualified Data.Semigroup as Semigroup+import qualified Data.Vector as Vector+import qualified Data.Vector as V+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 as Vector+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 a c1 -> a -> Vector c2+row g (Colonnade v) a = flip Vector.map v $+ \(OneColonnade _ encode) -> g (encode a)++bothMonadic_ :: Monad m+ => Colonnade Headed a c+ -> (c -> c -> m b)+ -> a+ -> m ()+bothMonadic_ (Colonnade v) g a =+ forM_ v $ \(OneColonnade (Headed h) encode) -> g h (encode a)++rowMonadic :: + (Monad m, Monoid b)+ => Colonnade f a c+ -> (c -> m b)+ -> a+ -> m b+rowMonadic (Colonnade v) g a =+ flip foldlMapM v+ $ \e -> g (oneColonnadeEncode e a)++rowMonadic_ :: + Monad m+ => Colonnade f a c+ -> (c -> m b)+ -> a+ -> m ()+rowMonadic_ (Colonnade v) g a =+ forM_ v $ \e -> g (oneColonnadeEncode e a)++rowMonoidal ::+ Monoid m+ => Colonnade h a c+ -> (c -> m)+ -> a+ -> m+rowMonoidal (Colonnade v) g a =+ foldMap (\(OneColonnade _ 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 (Maybe Int) 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 (Maybe Int) 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 (Just sz) h) enc)+ $ V.zip v (GV.convert sizeVec)++rowMonadicWith :: + (Monad m)+ => b+ -> (b -> b -> b)+ -> Colonnade f a c+ -> (c -> m b)+ -> a+ -> m b+rowMonadicWith bempty bappend (Colonnade v) g a =+ foldlM (\bl e -> do+ br <- g (oneColonnadeEncode e a)+ return (bappend bl br)+ ) bempty v++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 a c+ -> (c -> m b)+ -> m b+headerMonadicGeneral (Colonnade v) g = id+ $ fmap (mconcat . Vector.toList)+ $ Vector.mapM (foldlMapM g . oneColonnadeHead) v++headerMonadic :: + (Monad m, Monoid 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, Headedness h)+ => Colonnade h a c+ -> (c -> m b)+ -> m ()+headerMonadicGeneral_ (Colonnade v) g = case headednessExtract of+ Nothing -> return ()+ Just f -> Vector.mapM_ (g . f . oneColonnadeHead) v++headerMonoidalGeneral ::+ (Monoid m, Foldable h)+ => 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 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++discard :: Cornice h p a c -> Colonnade h a c+discard = go where+ go :: forall h p a c. Cornice h p a c -> Colonnade h a c+ go (CorniceBase c) = c+ go (CorniceCap children) = Colonnade (getColonnade . go . oneCorniceBody =<< children)++endow :: forall p a c. (c -> c -> c) -> Cornice Headed 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 Headed 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++uncapAnnotated :: forall sz p a c h.+ AnnotatedCornice sz h p a c+ -> Colonnade (Sized sz h) a c+uncapAnnotated x = case x of+ AnnotatedCorniceBase _ colonnade -> colonnade+ AnnotatedCorniceCap _ v -> Colonnade (V.concatMap (\(OneCornice _ b) -> go b) v)+ where+ go :: forall p'. + AnnotatedCornice sz h p' a c+ -> Vector (OneColonnade (Sized sz h) a c)+ go (AnnotatedCorniceBase _ (Colonnade v)) = v+ go (AnnotatedCorniceCap _ v) = V.concatMap (\(OneCornice _ b) -> go b) v++annotate :: Cornice Headed p a c -> AnnotatedCornice (Maybe Int) Headed p a c+annotate = go where+ go :: forall p a c. Cornice Headed p a c -> AnnotatedCornice (Maybe Int) Headed p a c+ go (CorniceBase c) = let len = V.length (getColonnade c) in+ AnnotatedCorniceBase+ (if len > 0 then (Just len) else Nothing)+ (mapHeadedness (Sized (Just 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 Headed p a c + -> AnnotatedCornice (Maybe Int) Headed 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 = 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) = 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 (Maybe Int) Headed p a c)+freezeMutableSizedCornice step finish = go+ where+ go :: forall p' a' c'.+ MutableSizedCornice s p' a' c' + -> ST s (AnnotatedCornice (Maybe Int) Headed p' a' c')+ go (MutableSizedCorniceBase msc) = do+ szCol <- freezeMutableSizedColonnade msc+ let sz = + ( mapJustInt finish + . V.foldl' (combineJustInt step) Nothing + . V.map (sizedSize . oneColonnadeHead)+ ) (getColonnade szCol)+ return (AnnotatedCorniceBase sz szCol)+ 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 Headed p a c + -> ST s (MutableSizedCornice s p a c)+newMutableSizedCornice = go where+ go :: forall p'. Cornice Headed p' a c -> ST s (MutableSizedCornice s p' a c)+ go (CorniceBase c) = fmap MutableSizedCorniceBase (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)+++-- | This is an O(1) operation, sort of+size :: AnnotatedCornice sz h p a c -> sz+size x = case x of+ AnnotatedCorniceBase m _ -> m+ 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 sz r m c p a h.+ (Monoid m, Headedness h)+ => Maybe (Fascia p r, r -> m -> m) -- ^ Apply the Fascia header row content+ -> [(sz -> c -> m, m -> m)] -- ^ Build content from cell content and size+ -> AnnotatedCornice sz h p a c+ -> m+headersMonoidal wrapRow fromContentList = go wrapRow+ where+ go :: forall p'. Maybe (Fascia p' r, r -> m -> m) -> AnnotatedCornice sz h p' a c -> m+ go ef (AnnotatedCorniceBase _ (Colonnade v)) = + let g :: m -> m+ g m = case ef of+ Nothing -> m+ Just (FasciaBase r, f) -> f r m+ in case headednessExtract of+ Just unhead -> g $ foldMap (\(fromContent,wrap) -> wrap + (foldMap (\(OneColonnade (Sized sz h) _) -> + (fromContent sz (unhead h))) v)) fromContentList+ Nothing -> mempty+ go ef (AnnotatedCorniceCap _ v) = + let g :: m -> m+ g m = case ef of+ Nothing -> m+ Just (FasciaCap r _, f) -> f r m+ in g (foldMap (\(fromContent,wrap) -> wrap (foldMap (\(OneCornice h b) -> + (fromContent (size b) h)) v)) fromContentList)+ <> case ef of+ Nothing -> case flattenAnnotated v of+ Nothing -> mempty+ Just annCoreNext -> go Nothing annCoreNext+ Just (FasciaCap _ fn, f) -> case flattenAnnotated v of+ Nothing -> mempty+ Just annCoreNext -> go (Just (fn,f)) annCoreNext++flattenAnnotated ::+ Vector (OneCornice (AnnotatedCornice sz h) p a c)+ -> Maybe (AnnotatedCornice sz h p a c)+flattenAnnotated v = case v V.!? 0 of + Nothing -> Nothing+ Just (OneCornice _ x) -> Just $ case x of+ AnnotatedCorniceBase m _ -> flattenAnnotatedBase m v+ AnnotatedCorniceCap m _ -> flattenAnnotatedCap m v++flattenAnnotatedBase ::+ sz+ -> Vector (OneCornice (AnnotatedCornice sz h) Base a c)+ -> AnnotatedCornice sz h Base a c+flattenAnnotatedBase msz = AnnotatedCorniceBase msz+ . Colonnade + . V.concatMap + (\(OneCornice _ (AnnotatedCorniceBase _ (Colonnade v))) -> v)++flattenAnnotatedCap ::+ sz+ -> Vector (OneCornice (AnnotatedCornice sz h) (Cap p) a c)+ -> AnnotatedCornice sz h (Cap p) a c+flattenAnnotatedCap m = AnnotatedCorniceCap m . V.concatMap getTheVector++getTheVector :: + OneCornice (AnnotatedCornice sz h) (Cap p) a c + -> Vector (OneCornice (AnnotatedCornice sz h) p a c)+getTheVector (OneCornice _ (AnnotatedCorniceCap _ v)) = v++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 MutableSizedColonnade s h a c = MutableSizedColonnade+ { _mutableSizedColonnadeColumns :: {-# UNPACK #-} !(Vector (OneColonnade h a c))+ , _mutableSizedColonnadeSizes :: {-# UNPACK #-} !(MVU.STVector s Int)+ }++-- | 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 Foo Text+--+-- 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)++instance Applicative Headed where+ pure = Headed+ Headed f <*> Headed a = Headed (f a)++-- | 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 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)++instance Applicative Headless where+ pure _ = Headless+ Headless <*> Headless = Headless++data Sized sz f a = Sized+ { sizedSize :: !sz+ , sizedContent :: !(f a)+ } deriving (Functor, Foldable)++instance Contravariant Headless where+ contramap _ Headless = Headless++-- | Encodes a header and a cell.+data OneColonnade h a c = OneColonnade+ { oneColonnadeHead :: !(h c)+ , oneColonnadeEncode :: !(a -> c)+ } deriving (Functor)++instance Functor h => Profunctor (OneColonnade h) where+ rmap = fmap+ lmap f (OneColonnade h e) = OneColonnade h (e . f)++-- | An columnar encoding of @a@. The type variable @h@ 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. Presented more visually:+--+-- > +---- Value consumed to build a row+-- > |+-- > v+-- > Colonnade h a c+-- > ^ ^+-- > | |+-- > | +-- Content (Text, ByteString, Html, etc.)+-- > |+-- > +------ Headedness (Headed or Headless)+--+-- 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 h a c = Colonnade+ { getColonnade :: Vector (OneColonnade h a c)+ } deriving (Monoid,Functor)++instance Functor h => Profunctor (Colonnade h) where+ rmap = fmap+ 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))++-- | 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 h 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)+ } deriving (Functor)++data Cornice h (p :: Pillar) a c where+ CorniceBase :: !(Colonnade h a c) -> Cornice h Base a c+ CorniceCap :: {-# UNPACK #-} !(Vector (OneCornice (Cornice h) p a c)) -> Cornice h (Cap p) a c++instance Functor h => Functor (Cornice h p a) where+ fmap f x = case x of+ CorniceBase c -> CorniceBase (fmap f c)+ CorniceCap c -> CorniceCap (mapVectorCornice f c)++instance Functor h => Profunctor (Cornice h p) where+ rmap = fmap+ lmap f x = case x of+ CorniceBase c -> CorniceBase (lmap f c)+ CorniceCap c -> CorniceCap (contramapVectorCornice f c)++instance Semigroup (Cornice h 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 h p a c) where+ mempty = toEmptyCornice+ mappend = (Semigroup.<>)+ mconcat xs1 = case xs1 of+ [] -> toEmptyCornice+ x : xs2 -> Semigroup.sconcat (x :| xs2)++mapVectorCornice :: Functor h => (c -> d) -> Vector (OneCornice (Cornice h) p a c) -> Vector (OneCornice (Cornice h) p a d)+mapVectorCornice f = V.map (fmap f)++contramapVectorCornice :: Functor h => (b -> a) -> Vector (OneCornice (Cornice h) p a c) -> Vector (OneCornice (Cornice h) p b c)+contramapVectorCornice f = V.map (lmapOneCornice f)++lmapOneCornice :: Functor h => (b -> a) -> OneCornice (Cornice h) p a c -> OneCornice (Cornice h) p b c+lmapOneCornice f (OneCornice theHead theBody) = OneCornice theHead (lmap f theBody) ++getCorniceBase :: Cornice h Base a c -> Colonnade h a c+getCorniceBase (CorniceBase c) = c++getCorniceCap :: Cornice h (Cap p) a c -> Vector (OneCornice (Cornice h) p a c)+getCorniceCap (CorniceCap c) = c++data AnnotatedCornice sz h (p :: Pillar) a c where+ AnnotatedCorniceBase ::+ !sz+ -> !(Colonnade (Sized sz h) a c)+ -> AnnotatedCornice sz h Base a c+ AnnotatedCorniceCap :: + !sz+ -> {-# UNPACK #-} !(Vector (OneCornice (AnnotatedCornice sz h) p a c))+ -> AnnotatedCornice sz h (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++-- | This class communicates that a container holds either zero+-- elements or one element. Furthermore, all inhabitants of+-- the type must hold the same number of elements. Both+-- 'Headed' and 'Headless' have instances. The following+-- law accompanies any instances:+--+-- > maybe x (\f -> f (headednessPure x)) headednessContents == x+-- > todo: come up with another law that relates to Traversable+--+-- Consequently, there is no instance for 'Maybe', which cannot+-- satisfy the laws since it has inhabitants which hold different+-- numbers of elements. 'Nothing' holds 0 elements and 'Just' holds+-- 1 element.+class Headedness h where+ headednessPure :: a -> h a+ headednessExtract :: Maybe (h a -> a)+ headednessExtractForall :: Maybe (ExtractForall h)++instance Headedness Headed where+ headednessPure = Headed+ headednessExtract = Just getHeaded + headednessExtractForall = Just (ExtractForall getHeaded)++instance Headedness Headless where+ headednessPure _ = Headless+ headednessExtract = Nothing+ headednessExtractForall = Nothing++newtype ExtractForall h = ExtractForall { runExtractForall :: forall a. h a -> a }+
− src/Colonnade/Encoding.hs
@@ -1,343 +0,0 @@--- | Build backend-agnostic columnar encodings that can be used to visualize data.--module Colonnade.Encoding- ( -- * Example- -- $setup- -- * Create- headed- , headless- -- * 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-import qualified Colonnade.Internal as Internal---- $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 :: Encoding Headed String Person--- encodingPerson = mconcat--- [ headed "Name" name--- , headed "Age" (show . age)--- ]--- :}------ The type signature on @basicPersonEncoding@ 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 :: Encoding 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) -> Encoding Headed c a-headed h = singleton (Headed h)---- | A single column without a header.-headless :: (a -> c) -> Encoding Headless c a-headless = singleton Headless---- | A single column with any kind of header. This is not typically needed.-singleton :: f c -> (a -> c) -> Encoding f c a-singleton h = Encoding . Vector.singleton . OneEncoding 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 :: Encoding 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 -> Encoding f c a -> Encoding f c (Maybe a)-fromMaybe c (Encoding v) = Encoding $ flip Vector.map v $- \(OneEncoding h encode) -> OneEncoding 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 :: Encoding Headed [Char] Color--- >>> let encHouse = headed "Price" (showDollar . price) <> contramap color encColor--- >>> :t encHouse--- encHouse :: Encoding 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- -> Encoding f c a-columns getCell getHeader = id- . Encoding- . Vector.map (\b -> OneEncoding (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- -> Encoding f c a-bool h p onTrue onFalse = singleton h (Data.Bool.bool <$> onFalse <*> onTrue <*> p)--replaceWhen ::- c- -> (a -> Bool)- -> Encoding f c a- -> Encoding f c a-replaceWhen newContent p (Encoding v) = Encoding- ( Vector.map- (\(OneEncoding h encode) -> OneEncoding h $ \a ->- if p a then newContent else encode a- ) v- )---- | 'Encoding' 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) -> Encoding f c1 a -> Encoding f c2 a-mapContent f (Encoding v) = Encoding- $ Vector.map (\(OneEncoding h c) -> (OneEncoding (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) -> Encoding f c1 a -> a -> Vector c2-runRow g (Encoding v) a = flip Vector.map v $- \(OneEncoding _ encode) -> g (encode a)--runBothMonadic_ :: Monad m- => Encoding Headed content a- -> (content -> content -> m b)- -> a- -> m ()-runBothMonadic_ (Encoding v) g a =- forM_ v $ \(OneEncoding (Headed h) encode) -> g h (encode a)--runRowMonadic :: (Monad m, Monoid b)- => Encoding f content a- -> (content -> m b)- -> a- -> m b-runRowMonadic (Encoding v) g a =- flip Internal.foldlMapM v- $ \e -> g (oneEncodingEncode e a)--runRowMonadic_ :: Monad m- => Encoding f content a- -> (content -> m b)- -> a- -> m ()-runRowMonadic_ (Encoding v) g a =- forM_ v $ \e -> g (oneEncodingEncode e a)--runRowMonadicWith :: (Monad m)- => b- -> (b -> b -> b)- -> Encoding f content a- -> (content -> m b)- -> a- -> m b-runRowMonadicWith bempty bappend (Encoding v) g a =- foldlM (\bl e -> do- br <- g (oneEncodingEncode e a)- return (bappend bl br)- ) bempty v--runHeader :: (c1 -> c2) -> Encoding Headed c1 a -> Vector c2-runHeader g (Encoding v) =- Vector.map (g . getHeaded . oneEncodingHead) 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)- => Encoding h content a- -> (content -> m b)- -> m b-runHeaderMonadicGeneral (Encoding v) g = id- $ fmap (mconcat . Vector.toList)- $ Vector.mapM (Internal.foldlMapM g . oneEncodingHead) v--runHeaderMonadic :: (Monad m, Monoid b)- => Encoding Headed content a- -> (content -> m b)- -> m b-runHeaderMonadic (Encoding v) g =- fmap (mconcat . Vector.toList) $ Vector.mapM (g . getHeaded . oneEncodingHead) v--runHeaderMonadicGeneral_ :: (Monad m, Monoid b, Foldable h)- => Encoding h content a- -> (content -> m b)- -> m ()-runHeaderMonadicGeneral_ (Encoding v) g =- Vector.mapM_ (Internal.foldlMapM g . oneEncodingHead) v--runHeaderMonadic_ ::- (Monad m)- => Encoding Headed content a- -> (content -> m b)- -> m ()-runHeaderMonadic_ (Encoding v) g = Vector.mapM_ (g . getHeaded . oneEncodingHead) v---- | Render a collection of rows as an ascii table. The table\'s columns are--- specified by the given 'Encoding'. 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- => Encoding 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)-
− src/Colonnade/Encoding/ByteString/Char8.hs
@@ -1,24 +0,0 @@-module Colonnade.Encoding.ByteString.Char8 where--import Data.ByteString (ByteString)-import qualified Data.ByteString as ByteString-import qualified Data.ByteString.Char8 as BC8-import qualified Data.ByteString.Builder as Builder-import qualified Data.ByteString.Lazy as LByteString--char :: Char -> ByteString-char = BC8.singleton--int :: Int -> ByteString-int = LByteString.toStrict- . Builder.toLazyByteString - . Builder.intDec--bool :: Bool -> ByteString-bool x = case x of- True -> BC8.pack "true"- False -> BC8.pack "false"--byteString :: ByteString -> ByteString-byteString = id-
− src/Colonnade/Encoding/Text.hs
@@ -1,24 +0,0 @@-module Colonnade.Encoding.Text where--import Data.Text-import qualified Data.Text as Text-import qualified Data.Text.Lazy as LText-import qualified Data.Text.Lazy.Builder as Builder-import qualified Data.Text.Lazy.Builder.Int as Builder--char :: Char -> Text-char = Text.singleton--int :: Int -> Text-int = LText.toStrict- . Builder.toLazyText- . Builder.decimal--text :: Text -> Text-text = id--bool :: Bool -> Text-bool x = case x of- True -> Text.pack "true"- False -> Text.pack "false"-
− src/Colonnade/Internal.hs
@@ -1,23 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-module Colonnade.Internal where--import Data.Foldable (foldrM,foldlM)--newtype EitherWrap a b = EitherWrap- { getEitherWrap :: Either a b- } deriving (Functor)--instance Monoid a => Applicative (EitherWrap a) where- pure = EitherWrap . Right- EitherWrap (Left a1) <*> EitherWrap (Left a2) = EitherWrap (Left (mappend a1 a2))- EitherWrap (Left a1) <*> EitherWrap (Right _) = EitherWrap (Left a1)- EitherWrap (Right _) <*> EitherWrap (Left a2) = EitherWrap (Left a2)- EitherWrap (Right f) <*> EitherWrap (Right b) = EitherWrap (Right (f b))--mapLeft :: (a -> b) -> Either a c -> Either b c-mapLeft _ (Right a) = Right a-mapLeft f (Left a) = Left (f a)--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-
− src/Colonnade/Types.hs
@@ -1,152 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE GADTs #-}-module Colonnade.Types- ( Encoding(..)- , Decoding(..)- , OneEncoding(..)- , Headed(..)- , Headless(..)- , Indexed(..)- , HeadingErrors(..)- , DecodingCellError(..)- , DecodingRowError(..)- , DecodingCellErrors(..)- , RowError(..)- ) 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---- | This type is isomorphic to 'Identity'.-newtype Headed a = Headed { getHeaded :: a }- deriving (Eq,Ord,Functor,Show,Read,Foldable)---- | This type is isomorphic to 'Proxy'-data Headless a = Headless- deriving (Eq,Ord,Functor,Show,Read,Foldable)--data Indexed f a = Indexed- { indexedIndex :: !Int- , indexedHeading :: !(f a)- } deriving (Eq,Ord,Functor,Show,Read)--data HeadingErrors content = HeadingErrors- { headingErrorsMissing :: Vector content -- ^ headers that were missing- , headingErrorsDuplicate :: Vector (content,Int) -- ^ headers that occurred more than once- } deriving (Show,Read,Eq)--instance (Show content, Typeable content) => Exception (HeadingErrors content)--instance Monoid (HeadingErrors content) where- mempty = HeadingErrors Vector.empty Vector.empty- mappend (HeadingErrors a1 b1) (HeadingErrors a2 b2) = HeadingErrors- (a1 Vector.++ a2) (b1 Vector.++ b2)--data DecodingCellError f content = DecodingCellError- { decodingCellErrorContent :: !content- , decodingCellErrorHeader :: !(Indexed f content)- , decodingCellErrorMessage :: !String- } deriving (Show,Read,Eq)---- instance (Show (f content), Typeable content) => Exception (DecodingError f content)--newtype DecodingCellErrors f content = DecodingCellErrors- { getDecodingCellErrors :: Vector (DecodingCellError f content)- } deriving (Monoid,Show,Read,Eq)---- newtype ParseRowError = ParseRowError String---- TODO: rewrite the instances for this by hand. They--- currently use FlexibleContexts.-data DecodingRowError f content = DecodingRowError- { decodingRowErrorRow :: !Int- , decodingRowErrorError :: !(RowError f content)- } deriving (Show,Read,Eq)---- TODO: rewrite the instances for this by hand. They--- currently use FlexibleContexts.-data RowError f content- = RowErrorParse !String -- ^ Error occurred parsing the document into cells- | RowErrorDecode !(DecodingCellErrors f content) -- ^ Error decoding the content- | RowErrorSize !Int !Int -- ^ Wrong number of cells in the row- | RowErrorHeading !(HeadingErrors content)- | RowErrorMinSize !Int !Int- | RowErrorMalformed !String -- ^ Error decoding unicode content- deriving (Show,Read,Eq)---- instance (Show (f content), Typeable content) => Exception (DecodingErrors f content)--instance Contravariant Headless where- contramap _ Headless = Headless---- | This just actually a specialization of the free applicative.--- Check out @Control.Applicative.Free@ in the @free@ library to--- learn more about this. The meanings of the fields are documented--- slightly more in the source code. Unfortunately, haddock does not--- play nicely with GADTs.-data Decoding f content a where- DecodingPure :: !a -- function- -> Decoding f content a- DecodingAp :: !(f content) -- header- -> !(content -> Either String a) -- decoding function- -> !(Decoding f content (a -> b)) -- next decoding- -> Decoding f content b--instance Functor (Decoding f content) where- fmap f (DecodingPure a) = DecodingPure (f a)- fmap f (DecodingAp h c apNext) = DecodingAp h c ((f .) <$> apNext)--instance Applicative (Decoding f content) where- pure = DecodingPure- DecodingPure f <*> y = fmap f y- DecodingAp h c y <*> z = DecodingAp h c (flip <$> y <*> z)---- | Encodes a header and a cell.-data OneEncoding f content a = OneEncoding- { oneEncodingHead :: !(f content)- , oneEncodingEncode :: !(a -> content)- }--instance Contravariant (OneEncoding f content) where- contramap f (OneEncoding h e) = OneEncoding 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, an 'Encoding' 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--- 'Encoding's are defined at the top-level so that GHC avoid reconstructing--- them every time they are used.-newtype Encoding f c a = Encoding- { getEncoding :: Vector (OneEncoding f c a)- } deriving (Monoid)--instance Contravariant (Encoding f content) where- contramap f (Encoding v) = Encoding- (Vector.map (contramap f) v)--instance Divisible (Encoding f content) where- conquer = Encoding Vector.empty- divide f (Encoding a) (Encoding b) =- Encoding $ (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)-
test/Main.hs view
@@ -2,5 +2,5 @@ main :: IO () main = doctest- [ "src/Colonnade/Encoding.hs"+ [ "src" ]