haskell/colonnade
1
0
Fork 1
mirror of https://github.com/byteverse/colonnade.git synced 2026-05-05 22:35:44 +02:00
Code Issues Actions Packages Projects Releases Wiki Activity

rename Encoding and Decoding to Colonnade and Decolonnade

Browse Source
This commit is contained in:
Andrew Martin 2017-01-31 19:02:11 -05:00
parent 2dea18bf68
commit 66e607f732
11 changed files with 194 additions and 292 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
colonnade/colonnade.cabal
View File

@ -1,7 +1,20 @@
name: colonnade name: colonnade
version: 0.4.7 version: 0.5
synopsis: Generic types and functions for columnar encoding and decoding synopsis: Generic types and functions for columnar encoding and decoding
description: Please see README.md description:
The `colonnade` package provides a way to 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/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 homepage: https://github.com/andrewthad/colonnade#readme
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
@ -17,16 +30,12 @@ library
exposed-modules: exposed-modules:
Colonnade.Types Colonnade.Types
Colonnade.Encoding Colonnade.Encoding
Colonnade.Encoding.Text
Colonnade.Encoding.ByteString.Char8
Colonnade.Decoding Colonnade.Decoding
Colonnade.Decoding.Text
Colonnade.Decoding.ByteString.Char8
Colonnade.Internal Colonnade.Internal
build-depends: build-depends:
base >= 4.7 && < 5 base >= 4.7 && < 5
, contravariant >= 1.2 && < 1.5 , contravariant >= 1.2 && < 1.5
, vector >= 0.10 && < 0.12 , vector >= 0.10 && < 0.13
, text >= 1.0 && < 1.3 , text >= 1.0 && < 1.3
, bytestring >= 0.10 && < 0.11 , bytestring >= 0.10 && < 0.11
default-language: Haskell2010 default-language: Haskell2010

104
colonnade/src/Colonnade/Decoding.hs
View File

@ -10,87 +10,87 @@ import Data.Vector (Vector)
import qualified Data.Vector as Vector import qualified Data.Vector as Vector
import Data.Char (chr) import Data.Char (chr)
-- | Converts the content type of a 'Decoding'. The @'Contravariant' f@ -- | Converts the content type of a 'Decolonnade'. The @'Contravariant' f@
-- constraint means that @f@ can be 'Headless' but not 'Headed'. -- 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 :: forall c1 c2 f a. Contravariant f => (c2 -> c1) -> Decolonnade f c1 a -> Decolonnade f c2 a
contramapContent f = go contramapContent f = go
where where
go :: forall b. Decoding f c1 b -> Decoding f c2 b go :: forall b. Decolonnade f c1 b -> Decolonnade f c2 b
go (DecodingPure x) = DecodingPure x go (DecolonnadePure x) = DecolonnadePure x
go (DecodingAp h decode apNext) = go (DecolonnadeAp h decode apNext) =
DecodingAp (contramap f h) (decode . f) (go apNext) DecolonnadeAp (contramap f h) (decode . f) (go apNext)
headless :: (content -> Either String a) -> Decoding Headless content a headless :: (content -> Either String a) -> Decolonnade Headless content a
headless f = DecodingAp Headless f (DecodingPure id) headless f = DecolonnadeAp Headless f (DecolonnadePure id)
headed :: content -> (content -> Either String a) -> Decoding Headed content a headed :: content -> (content -> Either String a) -> Decolonnade Headed content a
headed h f = DecodingAp (Headed h) f (DecodingPure id) headed h f = DecolonnadeAp (Headed h) f (DecolonnadePure id)
indexed :: Int -> (content -> Either String a) -> Decoding (Indexed Headless) content a indexed :: Int -> (content -> Either String a) -> Decolonnade (Indexed Headless) content a
indexed ix f = DecodingAp (Indexed ix Headless) f (DecodingPure id) indexed ix f = DecolonnadeAp (Indexed ix Headless) f (DecolonnadePure id)
maxIndex :: forall f c a. Decoding (Indexed f) c a -> Int maxIndex :: forall f c a. Decolonnade (Indexed f) c a -> Int
maxIndex = go 0 where maxIndex = go 0 where
go :: forall b. Int -> Decoding (Indexed f) c b -> Int go :: forall b. Int -> Decolonnade (Indexed f) c b -> Int
go !ix (DecodingPure _) = ix go !ix (DecolonnadePure _) = ix
go !ix1 (DecodingAp (Indexed ix2 _) decode apNext) = go !ix1 (DecolonnadeAp (Indexed ix2 _) decode apNext) =
go (max ix1 ix2) apNext go (max ix1 ix2) apNext
-- | This function uses 'unsafeIndex' to access -- | This function uses 'unsafeIndex' to access
-- elements of the 'Vector'. -- elements of the 'Vector'.
uncheckedRunWithRow :: uncheckedRunWithRow ::
Int Int
-> Decoding (Indexed f) content a -> Decolonnade (Indexed f) content a
-> Vector content -> Vector content
-> Either (DecodingRowError f content) a -> Either (DecolonnadeRowError f content) a
uncheckedRunWithRow i d v = mapLeft (DecodingRowError i . RowErrorDecode) (uncheckedRun d v) uncheckedRunWithRow i d v = mapLeft (DecolonnadeRowError i . RowErrorDecode) (uncheckedRun d v)
-- | This function does not check to make sure that the indicies in -- | This function does not check to make sure that the indicies in
-- the 'Decoding' are in the 'Vector'. -- the 'Decolonnade' are in the 'Vector'.
uncheckedRun :: forall content a f. uncheckedRun :: forall content a f.
Decoding (Indexed f) content a Decolonnade (Indexed f) content a
-> Vector content -> Vector content
-> Either (DecodingCellErrors f content) a -> Either (DecolonnadeCellErrors f content) a
uncheckedRun dc v = getEitherWrap (go dc) uncheckedRun dc v = getEitherWrap (go dc)
where where
go :: forall b. go :: forall b.
Decoding (Indexed f) content b Decolonnade (Indexed f) content b
-> EitherWrap (DecodingCellErrors f content) b -> EitherWrap (DecolonnadeCellErrors f content) b
go (DecodingPure b) = EitherWrap (Right b) go (DecolonnadePure b) = EitherWrap (Right b)
go (DecodingAp ixed@(Indexed ix h) decode apNext) = go (DecolonnadeAp ixed@(Indexed ix h) decode apNext) =
let rnext = go apNext let rnext = go apNext
content = Vector.unsafeIndex v ix content = Vector.unsafeIndex v ix
rcurrent = mapLeft (DecodingCellErrors . Vector.singleton . DecodingCellError content ixed) (decode content) rcurrent = mapLeft (DecolonnadeCellErrors . Vector.singleton . DecolonnadeCellError content ixed) (decode content)
in rnext <*> (EitherWrap rcurrent) in rnext <*> (EitherWrap rcurrent)
headlessToIndexed :: forall c a. headlessToIndexed :: forall c a.
Decoding Headless c a -> Decoding (Indexed Headless) c a Decolonnade Headless c a -> Decolonnade (Indexed Headless) c a
headlessToIndexed = go 0 where headlessToIndexed = go 0 where
go :: forall b. Int -> Decoding Headless c b -> Decoding (Indexed Headless) c b go :: forall b. Int -> Decolonnade Headless c b -> Decolonnade (Indexed Headless) c b
go !ix (DecodingPure a) = DecodingPure a go !ix (DecolonnadePure a) = DecolonnadePure a
go !ix (DecodingAp Headless decode apNext) = go !ix (DecolonnadeAp Headless decode apNext) =
DecodingAp (Indexed ix Headless) decode (go (ix + 1) apNext) DecolonnadeAp (Indexed ix Headless) decode (go (ix + 1) apNext)
length :: forall f c a. Decoding f c a -> Int length :: forall f c a. Decolonnade f c a -> Int
length = go 0 where length = go 0 where
go :: forall b. Int -> Decoding f c b -> Int go :: forall b. Int -> Decolonnade f c b -> Int
go !a (DecodingPure _) = a go !a (DecolonnadePure _) = a
go !a (DecodingAp _ _ apNext) = go (a + 1) apNext go !a (DecolonnadeAp _ _ apNext) = go (a + 1) apNext
-- | Maps over a 'Decoding' that expects headers, converting these -- | Maps over a 'Decolonnade' that expects headers, converting these
-- expected headers into the indices of the columns that they -- expected headers into the indices of the columns that they
-- correspond to. -- correspond to.
headedToIndexed :: forall content a. Eq content headedToIndexed :: forall content a. Eq content
=> Vector content -- ^ Headers in the source document => Vector content -- ^ Headers in the source document
-> Decoding Headed content a -- ^ Decoding that contains expected headers -> Decolonnade Headed content a -- ^ Decolonnade that contains expected headers
-> Either (HeadingErrors content) (Decoding (Indexed Headed) content a) -> Either (HeadingErrors content) (Decolonnade (Indexed Headed) content a)
headedToIndexed v = getEitherWrap . go headedToIndexed v = getEitherWrap . go
where where
go :: forall b. Eq content go :: forall b. Eq content
=> Decoding Headed content b => Decolonnade Headed content b
-> EitherWrap (HeadingErrors content) (Decoding (Indexed Headed) content b) -> EitherWrap (HeadingErrors content) (Decolonnade (Indexed Headed) content b)
go (DecodingPure b) = EitherWrap (Right (DecodingPure b)) go (DecolonnadePure b) = EitherWrap (Right (DecolonnadePure b))
go (DecodingAp hd@(Headed h) decode apNext) = go (DecolonnadeAp hd@(Headed h) decode apNext) =
let rnext = go apNext let rnext = go apNext
ixs = Vector.elemIndices h v ixs = Vector.elemIndices h v
ixsLen = Vector.length ixs ixsLen = Vector.length ixs
@ -98,15 +98,15 @@ headedToIndexed v = getEitherWrap . go
| ixsLen == 1 = Right (Vector.unsafeIndex ixs 0) | ixsLen == 1 = Right (Vector.unsafeIndex ixs 0)
| ixsLen == 0 = Left (HeadingErrors (Vector.singleton h) Vector.empty) | ixsLen == 0 = Left (HeadingErrors (Vector.singleton h) Vector.empty)
| otherwise = Left (HeadingErrors Vector.empty (Vector.singleton (h,ixsLen))) | otherwise = Left (HeadingErrors Vector.empty (Vector.singleton (h,ixsLen)))
in (\ix ap -> DecodingAp (Indexed ix hd) decode ap) in (\ix ap -> DecolonnadeAp (Indexed ix hd) decode ap)
<$> EitherWrap rcurrent <$> EitherWrap rcurrent
<*> rnext <*> rnext
-- | This adds one to the index because text editors consider -- | This adds one to the index because text editors consider
-- line number to be one-based, not zero-based. -- line number to be one-based, not zero-based.
prettyError :: (c -> String) -> DecodingRowError f c -> String prettyError :: (c -> String) -> DecolonnadeRowError f c -> String
prettyError toStr (DecodingRowError ix e) = unlines prettyError toStr (DecolonnadeRowError ix e) = unlines
$ ("Decoding error on line " ++ show (ix + 1) ++ " of file.") $ ("Decolonnade error on line " ++ show (ix + 1) ++ " of file.")
: ("Error Category: " ++ descr) : ("Error Category: " ++ descr)
: map (" " ++) errDescrs : map (" " ++) errDescrs
where (descr,errDescrs) = prettyRowError toStr e where (descr,errDescrs) = prettyRowError toStr e
@ -125,16 +125,16 @@ prettyRowError toStr x = case x of
[ "Expected the row to have at least " ++ show reqLen ++ " cells." [ "Expected the row to have at least " ++ show reqLen ++ " cells."
, "The row only has " ++ show actualLen ++ " cells." , "The row only has " ++ show actualLen ++ " cells."
] ]
RowErrorMalformed enc -> (,) "Text Decoding" RowErrorMalformed enc -> (,) "Text Decolonnade"
[ "Tried to decode the input as " ++ enc ++ " text" [ "Tried to decode the input as " ++ enc ++ " text"
, "There is a mistake in the encoding of the text." , "There is a mistake in the encoding of the text."
] ]
RowErrorHeading errs -> (,) "Header" (prettyHeadingErrors toStr errs) RowErrorHeading errs -> (,) "Header" (prettyHeadingErrors toStr errs)
RowErrorDecode errs -> (,) "Cell Decoding" (prettyCellErrors toStr errs) RowErrorDecode errs -> (,) "Cell Decolonnade" (prettyCellErrors toStr errs)
prettyCellErrors :: (c -> String) -> DecodingCellErrors f c -> [String] prettyCellErrors :: (c -> String) -> DecolonnadeCellErrors f c -> [String]
prettyCellErrors toStr (DecodingCellErrors errs) = drop 1 $ prettyCellErrors toStr (DecolonnadeCellErrors errs) = drop 1 $
flip concatMap errs $ \(DecodingCellError content (Indexed ix _) msg) -> flip concatMap errs $ \(DecolonnadeCellError content (Indexed ix _) msg) ->
let str = toStr content in let str = toStr content in
[ "-----------" [ "-----------"
, "Column " ++ columnNumToLetters ix , "Column " ++ columnNumToLetters ix

26
colonnade/src/Colonnade/Decoding/ByteString/Char8.hs
View File

@ -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"

47
colonnade/src/Colonnade/Decoding/Text.hs
View File

@ -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)

112
colonnade/src/Colonnade/Encoding.hs
View File

@ -57,14 +57,14 @@ import qualified Colonnade.Internal as Internal
-- One potential columnar encoding of a @Person@ would be: -- One potential columnar encoding of a @Person@ would be:
-- --
-- >>> :{ -- >>> :{
-- let encodingPerson :: Encoding Headed String Person -- let encodingPerson :: Colonnade Headed String Person
-- encodingPerson = mconcat -- encodingPerson = mconcat
-- [ headed "Name" name -- [ headed "Name" name
-- , headed "Age" (show . age) -- , headed "Age" (show . age)
-- ] -- ]
-- :} -- :}
-- --
-- The type signature on @basicPersonEncoding@ is not neccessary -- The type signature on @encodingPerson@ is not neccessary
-- but is included for clarity. We can feed data into this encoding -- but is included for clarity. We can feed data into this encoding
-- to build a table: -- to build a table:
-- --
@ -82,7 +82,7 @@ import qualified Colonnade.Internal as Internal
-- --
-- >>> let showDollar = (('$':) . show) :: Int -> String -- >>> let showDollar = (('$':) . show) :: Int -> String
-- >>> :{ -- >>> :{
-- let encodingHouse :: Encoding Headed String House -- let encodingHouse :: Colonnade Headed String House
-- encodingHouse = mconcat -- encodingHouse = mconcat
-- [ headed "Color" (show . color) -- [ headed "Color" (show . color)
-- , headed "Price" (showDollar . price) -- , headed "Price" (showDollar . price)
@ -101,16 +101,16 @@ import qualified Colonnade.Internal as Internal
-- | A single column with a header. -- | A single column with a header.
headed :: c -> (a -> c) -> Encoding Headed c a headed :: c -> (a -> c) -> Colonnade Headed c a
headed h = singleton (Headed h) headed h = singleton (Headed h)
-- | A single column without a header. -- | A single column without a header.
headless :: (a -> c) -> Encoding Headless c a headless :: (a -> c) -> Colonnade Headless c a
headless = singleton Headless headless = singleton Headless
-- | A single column with any kind of header. This is not typically needed. -- | A single column with any kind of header. This is not typically needed.
singleton :: f c -> (a -> c) -> Encoding f c a singleton :: f c -> (a -> c) -> Colonnade f c a
singleton h = Encoding . Vector.singleton . OneEncoding h singleton h = Colonnade . Vector.singleton . OneColonnade h
-- | Lift a column over a 'Maybe'. For example, if some people -- | Lift a column over a 'Maybe'. For example, if some people
-- have houses and some do not, the data that pairs them together -- have houses and some do not, the data that pairs them together
@ -129,7 +129,7 @@ singleton h = Encoding . Vector.singleton . OneEncoding h
-- the help of 'fromMaybe': -- the help of 'fromMaybe':
-- --
-- >>> :{ -- >>> :{
-- >>> let encodingOwners :: Encoding Headed String (Person,Maybe House) -- >>> let encodingOwners :: Colonnade Headed String (Person,Maybe House)
-- >>> encodingOwners = mconcat -- >>> encodingOwners = mconcat
-- >>> [ contramap fst encodingPerson -- >>> [ contramap fst encodingPerson
-- >>> , contramap snd (fromMaybe "" encodingHouse) -- >>> , contramap snd (fromMaybe "" encodingHouse)
@ -144,9 +144,9 @@ singleton h = Encoding . Vector.singleton . OneEncoding h
-- | Ruth | 25 | Red | $125000 | -- | Ruth | 25 | Red | $125000 |
-- | Sonia | 12 | Green | $145000 | -- | Sonia | 12 | Green | $145000 |
-- +--------+-----+-------+---------+ -- +--------+-----+-------+---------+
fromMaybe :: c -> Encoding f c a -> Encoding f c (Maybe a) fromMaybe :: c -> Colonnade f c a -> Colonnade f c (Maybe a)
fromMaybe c (Encoding v) = Encoding $ flip Vector.map v $ fromMaybe c (Colonnade v) = Colonnade $ flip Vector.map v $
\(OneEncoding h encode) -> OneEncoding h (maybe c encode) \(OneColonnade h encode) -> OneColonnade h (maybe c encode)
-- | Convert a collection of @b@ values into a columnar encoding of -- | Convert a collection of @b@ values into a columnar encoding of
-- the same size. Suppose we decide to show a house\'s color -- the same size. Suppose we decide to show a house\'s color
@ -156,10 +156,10 @@ fromMaybe c (Encoding v) = Encoding $ flip Vector.map v $
-- >>> let allColors = [Red,Green,Blue] -- >>> let allColors = [Red,Green,Blue]
-- >>> let encColor = columns (\c1 c2 -> if c1 == c2 then "✓" else "") (Headed . show) allColors -- >>> let encColor = columns (\c1 c2 -> if c1 == c2 then "✓" else "") (Headed . show) allColors
-- >>> :t encColor -- >>> :t encColor
-- encColor :: Encoding Headed [Char] Color -- encColor :: Colonnade Headed [Char] Color
-- >>> let encHouse = headed "Price" (showDollar . price) <> contramap color encColor -- >>> let encHouse = headed "Price" (showDollar . price) <> contramap color encColor
-- >>> :t encHouse -- >>> :t encHouse
-- encHouse :: Encoding Headed [Char] House -- encHouse :: Colonnade Headed [Char] House
-- >>> putStr (ascii encHouse houses) -- >>> putStr (ascii encHouse houses)
-- +---------+-----+-------+------+ -- +---------+-----+-------+------+
-- | Price | Red | Green | Blue | -- | Price | Red | Green | Blue |
@ -172,10 +172,10 @@ columns :: Foldable g
=> (b -> a -> c) -- ^ Cell content function => (b -> a -> c) -- ^ Cell content function
-> (b -> f c) -- ^ Header content function -> (b -> f c) -- ^ Header content function
-> g b -- ^ Basis for column encodings -> g b -- ^ Basis for column encodings
-> Encoding f c a -> Colonnade f c a
columns getCell getHeader = id columns getCell getHeader = id
. Encoding . Colonnade
. Vector.map (\b -> OneEncoding (getHeader b) (getCell b)) . Vector.map (\b -> OneColonnade (getHeader b) (getCell b))
. Vector.fromList . Vector.fromList
. toList . toList
@ -184,116 +184,116 @@ bool ::
-> (a -> Bool) -- ^ Predicate -> (a -> Bool) -- ^ Predicate
-> (a -> c) -- ^ Contents when predicate is false -> (a -> c) -- ^ Contents when predicate is false
-> (a -> c) -- ^ Contents when predicate is true -> (a -> c) -- ^ Contents when predicate is true
-> Encoding f c a -> Colonnade f c a
bool h p onTrue onFalse = singleton h (Data.Bool.bool <$> onFalse <*> onTrue <*> p) bool h p onTrue onFalse = singleton h (Data.Bool.bool <$> onFalse <*> onTrue <*> p)
replaceWhen :: replaceWhen ::
c c
-> (a -> Bool) -> (a -> Bool)
-> Encoding f c a -> Colonnade f c a
-> Encoding f c a -> Colonnade f c a
replaceWhen newContent p (Encoding v) = Encoding replaceWhen newContent p (Colonnade v) = Colonnade
( Vector.map ( Vector.map
(\(OneEncoding h encode) -> OneEncoding h $ \a -> (\(OneColonnade h encode) -> OneColonnade h $ \a ->
if p a then newContent else encode a if p a then newContent else encode a
) v ) v
) )
-- | 'Encoding' is covariant in its content type. Consequently, it can be -- | 'Colonnade' is covariant in its content type. Consequently, it can be
-- mapped over. There is no standard typeclass for types that are covariant -- mapped over. There is no standard typeclass for types that are covariant
-- in their second-to-last argument, so this function is provided for -- in their second-to-last argument, so this function is provided for
-- situations that require this. -- situations that require this.
mapContent :: Functor f => (c1 -> c2) -> Encoding f c1 a -> Encoding f c2 a mapContent :: Functor f => (c1 -> c2) -> Colonnade f c1 a -> Colonnade f c2 a
mapContent f (Encoding v) = Encoding mapContent f (Colonnade v) = Colonnade
$ Vector.map (\(OneEncoding h c) -> (OneEncoding (fmap f h) (f . c))) v $ Vector.map (\(OneColonnade h c) -> (OneColonnade (fmap f h) (f . c))) v
-- | Consider providing a variant the produces a list -- | Consider providing a variant the produces a list
-- instead. It may allow more things to get inlined -- instead. It may allow more things to get inlined
-- in to a loop. -- in to a loop.
runRow :: (c1 -> c2) -> Encoding f c1 a -> a -> Vector c2 runRow :: (c1 -> c2) -> Colonnade f c1 a -> a -> Vector c2
runRow g (Encoding v) a = flip Vector.map v $ runRow g (Colonnade v) a = flip Vector.map v $
\(OneEncoding _ encode) -> g (encode a) \(OneColonnade _ encode) -> g (encode a)
runBothMonadic_ :: Monad m runBothMonadic_ :: Monad m
=> Encoding Headed content a => Colonnade Headed content a
-> (content -> content -> m b) -> (content -> content -> m b)
-> a -> a
-> m () -> m ()
runBothMonadic_ (Encoding v) g a = runBothMonadic_ (Colonnade v) g a =
forM_ v $ \(OneEncoding (Headed h) encode) -> g h (encode a) forM_ v $ \(OneColonnade (Headed h) encode) -> g h (encode a)
runRowMonadic :: (Monad m, Monoid b) runRowMonadic :: (Monad m, Monoid b)
=> Encoding f content a => Colonnade f content a
-> (content -> m b) -> (content -> m b)
-> a -> a
-> m b -> m b
runRowMonadic (Encoding v) g a = runRowMonadic (Colonnade v) g a =
flip Internal.foldlMapM v flip Internal.foldlMapM v
$ \e -> g (oneEncodingEncode e a) $ \e -> g (oneColonnadeEncode e a)
runRowMonadic_ :: Monad m runRowMonadic_ :: Monad m
=> Encoding f content a => Colonnade f content a
-> (content -> m b) -> (content -> m b)
-> a -> a
-> m () -> m ()
runRowMonadic_ (Encoding v) g a = runRowMonadic_ (Colonnade v) g a =
forM_ v $ \e -> g (oneEncodingEncode e a) forM_ v $ \e -> g (oneColonnadeEncode e a)
runRowMonadicWith :: (Monad m) runRowMonadicWith :: (Monad m)
=> b => b
-> (b -> b -> b) -> (b -> b -> b)
-> Encoding f content a -> Colonnade f content a
-> (content -> m b) -> (content -> m b)
-> a -> a
-> m b -> m b
runRowMonadicWith bempty bappend (Encoding v) g a = runRowMonadicWith bempty bappend (Colonnade v) g a =
foldlM (\bl e -> do foldlM (\bl e -> do
br <- g (oneEncodingEncode e a) br <- g (oneColonnadeEncode e a)
return (bappend bl br) return (bappend bl br)
) bempty v ) bempty v
runHeader :: (c1 -> c2) -> Encoding Headed c1 a -> Vector c2 runHeader :: (c1 -> c2) -> Colonnade Headed c1 a -> Vector c2
runHeader g (Encoding v) = runHeader g (Colonnade v) =
Vector.map (g . getHeaded . oneEncodingHead) v Vector.map (g . getHeaded . oneColonnadeHead) v
-- | This function is a helper for abusing 'Foldable' to optionally -- | This function is a helper for abusing 'Foldable' to optionally
-- render a header. Its future is uncertain. -- render a header. Its future is uncertain.
runHeaderMonadicGeneral :: (Monad m, Monoid b, Foldable h) runHeaderMonadicGeneral :: (Monad m, Monoid b, Foldable h)
=> Encoding h content a => Colonnade h content a
-> (content -> m b) -> (content -> m b)
-> m b -> m b
runHeaderMonadicGeneral (Encoding v) g = id runHeaderMonadicGeneral (Colonnade v) g = id
$ fmap (mconcat . Vector.toList) $ fmap (mconcat . Vector.toList)
$ Vector.mapM (Internal.foldlMapM g . oneEncodingHead) v $ Vector.mapM (Internal.foldlMapM g . oneColonnadeHead) v
runHeaderMonadic :: (Monad m, Monoid b) runHeaderMonadic :: (Monad m, Monoid b)
=> Encoding Headed content a => Colonnade Headed content a
-> (content -> m b) -> (content -> m b)
-> m b -> m b
runHeaderMonadic (Encoding v) g = runHeaderMonadic (Colonnade v) g =
fmap (mconcat . Vector.toList) $ Vector.mapM (g . getHeaded . oneEncodingHead) v fmap (mconcat . Vector.toList) $ Vector.mapM (g . getHeaded . oneColonnadeHead) v
runHeaderMonadicGeneral_ :: (Monad m, Monoid b, Foldable h) runHeaderMonadicGeneral_ :: (Monad m, Monoid b, Foldable h)
=> Encoding h content a => Colonnade h content a
-> (content -> m b) -> (content -> m b)
-> m () -> m ()
runHeaderMonadicGeneral_ (Encoding v) g = runHeaderMonadicGeneral_ (Colonnade v) g =
Vector.mapM_ (Internal.foldlMapM g . oneEncodingHead) v Vector.mapM_ (Internal.foldlMapM g . oneColonnadeHead) v
runHeaderMonadic_ :: runHeaderMonadic_ ::
(Monad m) (Monad m)
=> Encoding Headed content a => Colonnade Headed content a
-> (content -> m b) -> (content -> m b)
-> m () -> m ()
runHeaderMonadic_ (Encoding v) g = Vector.mapM_ (g . getHeaded . oneEncodingHead) v runHeaderMonadic_ (Colonnade v) g = Vector.mapM_ (g . getHeaded . oneColonnadeHead) v
-- | Render a collection of rows as an ascii table. The table\'s columns are -- | Render a collection of rows as an ascii table. The table\'s columns are
-- specified by the given 'Encoding'. This implementation is inefficient and -- specified by the given 'Colonnade'. This implementation is inefficient and
-- does not provide any wrapping behavior. It is provided so that users can -- 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 examples
-- code in the haddocks. -- code in the haddocks.
ascii :: Foldable f ascii :: Foldable f
=> Encoding Headed String a -- ^ columnar encoding => Colonnade Headed String a -- ^ columnar encoding
-> f a -- ^ rows -> f a -- ^ rows
-> String -> String
ascii enc xs = ascii enc xs =

24
colonnade/src/Colonnade/Encoding/ByteString/Char8.hs
View File

@ -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

24
colonnade/src/Colonnade/Encoding/Text.hs
View File

@ -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"

82
colonnade/src/Colonnade/Types.hs
View File

@ -3,16 +3,16 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
module Colonnade.Types module Colonnade.Types
( Encoding(..) ( Colonnade(..)
, Decoding(..) , Decolonnade(..)
, OneEncoding(..) , OneColonnade(..)
, Headed(..) , Headed(..)
, Headless(..) , Headless(..)
, Indexed(..) , Indexed(..)
, HeadingErrors(..) , HeadingErrors(..)
, DecodingCellError(..) , DecolonnadeCellError(..)
, DecodingRowError(..) , DecolonnadeRowError(..)
, DecodingCellErrors(..) , DecolonnadeCellErrors(..)
, RowError(..) , RowError(..)
) where ) where
@ -48,23 +48,23 @@ instance Monoid (HeadingErrors content) where
mappend (HeadingErrors a1 b1) (HeadingErrors a2 b2) = HeadingErrors mappend (HeadingErrors a1 b1) (HeadingErrors a2 b2) = HeadingErrors
(a1 Vector.++ a2) (b1 Vector.++ b2) (a1 Vector.++ a2) (b1 Vector.++ b2)
data DecodingCellError f content = DecodingCellError data DecolonnadeCellError f content = DecolonnadeCellError
{ decodingCellErrorContent :: !content { decodingCellErrorContent :: !content
, decodingCellErrorHeader :: !(Indexed f content) , decodingCellErrorHeader :: !(Indexed f content)
, decodingCellErrorMessage :: !String , decodingCellErrorMessage :: !String
} deriving (Show,Read,Eq) } deriving (Show,Read,Eq)
-- instance (Show (f content), Typeable content) => Exception (DecodingError f content) -- instance (Show (f content), Typeable content) => Exception (DecolonnadeError f content)
newtype DecodingCellErrors f content = DecodingCellErrors newtype DecolonnadeCellErrors f content = DecolonnadeCellErrors
{ getDecodingCellErrors :: Vector (DecodingCellError f content) { getDecolonnadeCellErrors :: Vector (DecolonnadeCellError f content)
} deriving (Monoid,Show,Read,Eq) } deriving (Monoid,Show,Read,Eq)
-- newtype ParseRowError = ParseRowError String -- newtype ParseRowError = ParseRowError String
-- TODO: rewrite the instances for this by hand. They -- TODO: rewrite the instances for this by hand. They
-- currently use FlexibleContexts. -- currently use FlexibleContexts.
data DecodingRowError f content = DecodingRowError data DecolonnadeRowError f content = DecolonnadeRowError
{ decodingRowErrorRow :: !Int { decodingRowErrorRow :: !Int
, decodingRowErrorError :: !(RowError f content) , decodingRowErrorError :: !(RowError f content)
} deriving (Show,Read,Eq) } deriving (Show,Read,Eq)
@ -73,14 +73,14 @@ data DecodingRowError f content = DecodingRowError
-- currently use FlexibleContexts. -- currently use FlexibleContexts.
data RowError f content data RowError f content
= RowErrorParse !String -- ^ Error occurred parsing the document into cells = RowErrorParse !String -- ^ Error occurred parsing the document into cells
| RowErrorDecode !(DecodingCellErrors f content) -- ^ Error decoding the content | RowErrorDecode !(DecolonnadeCellErrors f content) -- ^ Error decoding the content
| RowErrorSize !Int !Int -- ^ Wrong number of cells in the row | RowErrorSize !Int !Int -- ^ Wrong number of cells in the row
| RowErrorHeading !(HeadingErrors content) | RowErrorHeading !(HeadingErrors content)
| RowErrorMinSize !Int !Int | RowErrorMinSize !Int !Int
| RowErrorMalformed !String -- ^ Error decoding unicode content | RowErrorMalformed !String -- ^ Error decoding unicode content
deriving (Show,Read,Eq) deriving (Show,Read,Eq)
-- instance (Show (f content), Typeable content) => Exception (DecodingErrors f content) -- instance (Show (f content), Typeable content) => Exception (DecolonnadeErrors f content)
instance Contravariant Headless where instance Contravariant Headless where
contramap _ Headless = Headless contramap _ Headless = Headless
@ -90,31 +90,31 @@ instance Contravariant Headless where
-- learn more about this. The meanings of the fields are documented -- learn more about this. The meanings of the fields are documented
-- slightly more in the source code. Unfortunately, haddock does not -- slightly more in the source code. Unfortunately, haddock does not
-- play nicely with GADTs. -- play nicely with GADTs.
data Decoding f content a where data Decolonnade f content a where
DecodingPure :: !a -- function DecolonnadePure :: !a -- function
-> Decoding f content a -> Decolonnade f content a
DecodingAp :: !(f content) -- header DecolonnadeAp :: !(f content) -- header
-> !(content -> Either String a) -- decoding function -> !(content -> Either String a) -- decoding function
-> !(Decoding f content (a -> b)) -- next decoding -> !(Decolonnade f content (a -> b)) -- next decoding
-> Decoding f content b -> Decolonnade f content b
instance Functor (Decoding f content) where instance Functor (Decolonnade f content) where
fmap f (DecodingPure a) = DecodingPure (f a) fmap f (DecolonnadePure a) = DecolonnadePure (f a)
fmap f (DecodingAp h c apNext) = DecodingAp h c ((f .) <$> apNext) fmap f (DecolonnadeAp h c apNext) = DecolonnadeAp h c ((f .) <$> apNext)
instance Applicative (Decoding f content) where instance Applicative (Decolonnade f content) where
pure = DecodingPure pure = DecolonnadePure
DecodingPure f <*> y = fmap f y DecolonnadePure f <*> y = fmap f y
DecodingAp h c y <*> z = DecodingAp h c (flip <$> y <*> z) DecolonnadeAp h c y <*> z = DecolonnadeAp h c (flip <$> y <*> z)
-- | Encodes a header and a cell. -- | Encodes a header and a cell.
data OneEncoding f content a = OneEncoding data OneColonnade f content a = OneColonnade
{ oneEncodingHead :: !(f content) { oneColonnadeHead :: !(f content)
, oneEncodingEncode :: !(a -> content) , oneColonnadeEncode :: !(a -> content)
} }
instance Contravariant (OneEncoding f content) where instance Contravariant (OneColonnade f content) where
contramap f (OneEncoding h e) = OneEncoding h (e . f) contramap f (OneColonnade h e) = OneColonnade h (e . f)
-- | An columnar encoding of @a@. The type variable @f@ determines what -- | An columnar encoding of @a@. The type variable @f@ determines what
-- is present in each column in the header row. It is typically instantiated -- is present in each column in the header row. It is typically instantiated
@ -126,25 +126,25 @@ instance Contravariant (OneEncoding f content) where
-- that represent HTML with element attributes are provided that serve -- that represent HTML with element attributes are provided that serve
-- as the content type. -- as the content type.
-- --
-- Internally, an 'Encoding' is represented as a 'Vector' of individual -- Internally, a 'Colonnade' is represented as a 'Vector' of individual
-- column encodings. It is possible to use any collection type with -- column encodings. It is possible to use any collection type with
-- 'Alternative' and 'Foldable' instances. However, 'Vector' was chosen to -- 'Alternative' and 'Foldable' instances. However, 'Vector' was chosen to
-- optimize the data structure for the use case of building the structure -- optimize the data structure for the use case of building the structure
-- once and then folding over it many times. It is recommended that -- 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 -- 'Colonnade's are defined at the top-level so that GHC avoid reconstructing
-- them every time they are used. -- them every time they are used.
newtype Encoding f c a = Encoding newtype Colonnade f c a = Colonnade
{ getEncoding :: Vector (OneEncoding f c a) { getColonnade :: Vector (OneColonnade f c a)
} deriving (Monoid) } deriving (Monoid)
instance Contravariant (Encoding f content) where instance Contravariant (Colonnade f content) where
contramap f (Encoding v) = Encoding contramap f (Colonnade v) = Colonnade
(Vector.map (contramap f) v) (Vector.map (contramap f) v)
instance Divisible (Encoding f content) where instance Divisible (Colonnade f content) where
conquer = Encoding Vector.empty conquer = Colonnade Vector.empty
divide f (Encoding a) (Encoding b) = divide f (Colonnade a) (Colonnade b) =
Encoding $ (Vector.++) Colonnade $ (Vector.++)
(Vector.map (contramap (fst . f)) a) (Vector.map (contramap (fst . f)) a)
(Vector.map (contramap (snd . f)) b) (Vector.map (contramap (snd . f)) b)
-- (Vector.map (\(OneEncoding h c) -> (h,c . fst . f)) a) -- (Vector.map (\(OneEncoding h c) -> (h,c . fst . f)) a)

2
stack.yaml
View File

@ -15,7 +15,7 @@
# resolver: # resolver:
# name: custom-snapshot # name: custom-snapshot
# location: "./custom-snapshot.yaml" # location: "./custom-snapshot.yaml"
resolver: lts-6.4 resolver: lts-6.5
# User packages to be built. # User packages to be built.
# Various formats can be used as shown in the example below. # Various formats can be used as shown in the example below.

38
yesod-colonnade/src/Yesod/Colonnade.hs
View File

@ -2,20 +2,22 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
module Yesod.Colonnade module Yesod.Colonnade
( table ( -- * Build Encoding
, tableHeadless Cell(..)
, definitionTable
, listItems
, Cell(..)
, cell , cell
, stringCell , stringCell
, textCell , textCell
, builderCell , builderCell
, anchorCell , anchorCell
-- * Apply Encoding
, table
, tableHeadless
, definitionTable
, listItems
) where ) where
import Yesod.Core import Yesod.Core
import Colonnade.Types import Colonnade.Types (Colonnade,Headed,Headless)
import Data.Text (Text) import Data.Text (Text)
import Control.Monad import Control.Monad
import Data.Monoid import Data.Monoid
@ -25,6 +27,8 @@ import qualified Data.Text as Text
import qualified Data.Text.Lazy as LText import qualified Data.Text.Lazy as LText
import qualified Data.Text.Lazy.Builder as TBuilder import qualified Data.Text.Lazy.Builder as TBuilder
-- | The attributes that will be applied to a @<td>@ and
-- the HTML content that will go inside it.
data Cell site = Cell data Cell site = Cell
{ cellAttrs :: ![(Text,Text)] { cellAttrs :: ![(Text,Text)]
, cellContents :: !(WidgetT site IO ()) , cellContents :: !(WidgetT site IO ())
@ -37,19 +41,29 @@ instance Monoid (Cell site) where
mempty = Cell [] mempty mempty = Cell [] mempty
mappend (Cell a1 c1) (Cell a2 c2) = Cell (mappend a1 a2) (mappend c1 c2) mappend (Cell a1 c1) (Cell a2 c2) = Cell (mappend a1 a2) (mappend c1 c2)
-- | Create a 'Cell' from a 'Widget'
cell :: WidgetT site IO () -> Cell site cell :: WidgetT site IO () -> Cell site
cell = Cell [] cell = Cell []
-- | Create a 'Cell' from a 'String'
stringCell :: String -> Cell site stringCell :: String -> Cell site
stringCell = cell . fromString stringCell = cell . fromString
-- | Create a 'Cell' from a 'Text'
textCell :: Text -> Cell site textCell :: Text -> Cell site
textCell = cell . toWidget . toHtml textCell = cell . toWidget . toHtml
-- | Create a 'Cell' from a text builder
builderCell :: TBuilder.Builder -> Cell site builderCell :: TBuilder.Builder -> Cell site
builderCell = cell . toWidget . toHtml . LText.toStrict . TBuilder.toLazyText builderCell = cell . toWidget . toHtml . LText.toStrict . TBuilder.toLazyText
anchorCell :: (a -> Route site) -> (a -> WidgetT site IO ()) -> a -> Cell site -- | Creata a 'Cell' whose content is hyperlinked by wrapping
-- it in an @<a>@.
anchorCell ::
(a -> Route site) -- ^ Route that will go in @href@
-> (a -> WidgetT site IO ()) -- ^ Content wrapped by @<a>@
-> a -- ^ Value
-> Cell site
anchorCell getRoute getContent a = cell $ do anchorCell getRoute getContent a = cell $ do
urlRender <- getUrlRender urlRender <- getUrlRender
aTag [(Text.pack "href",urlRender (getRoute a))] (getContent a) aTag [(Text.pack "href",urlRender (getRoute a))] (getContent a)
@ -62,7 +76,7 @@ listItems ::
-- ^ Wrapper for items, often @ul@ -- ^ Wrapper for items, often @ul@
-> (WidgetT site IO () -> WidgetT site IO () -> WidgetT site IO ()) -> (WidgetT site IO () -> WidgetT site IO () -> WidgetT site IO ())
-- ^ Combines header with data -- ^ Combines header with data
-> Encoding Headed (Cell site) a -> Colonnade Headed (Cell site) a
-- ^ How to encode data as a row -- ^ How to encode data as a row
-> a -> a
-- ^ The value to display -- ^ The value to display
@ -79,7 +93,7 @@ listItems ulWrap combine enc =
definitionTable :: definitionTable ::
[(Text,Text)] [(Text,Text)]
-- ^ Attributes of @table@ element. -- ^ Attributes of @table@ element.
-> Encoding Headed (Cell site) a -> Colonnade Headed (Cell site) a
-- ^ How to encode data as a row -- ^ How to encode data as a row
-> a -> a
-- ^ The value to display -- ^ The value to display
@ -97,7 +111,7 @@ definitionTable attrs enc a = tableEl attrs $ tbody [] $
-- > table [("class","table table-striped")] ... -- > table [("class","table table-striped")] ...
table :: Foldable f table :: Foldable f
=> [(Text,Text)] -- ^ Attributes of @table@ element => [(Text,Text)] -- ^ Attributes of @table@ element
-> Encoding Headed (Cell site) a -- ^ How to encode data as a row -> Colonnade Headed (Cell site) a -- ^ How to encode data as a row
-> f a -- ^ Rows of data -> f a -- ^ Rows of data
-> WidgetT site IO () -> WidgetT site IO ()
table attrs enc xs = tableEl attrs $ do table attrs enc xs = tableEl attrs $ do
@ -106,13 +120,13 @@ table attrs enc xs = tableEl attrs $ do
tableHeadless :: Foldable f tableHeadless :: Foldable f
=> [(Text,Text)] -- ^ Attributes of @table@ element => [(Text,Text)] -- ^ Attributes of @table@ element
-> Encoding Headless (Cell site) a -- ^ How to encode data as a row -> Colonnade Headless (Cell site) a -- ^ How to encode data as a row
-> f a -- ^ Rows of data -> f a -- ^ Rows of data
-> WidgetT site IO () -> WidgetT site IO ()
tableHeadless attrs enc xs = tableEl attrs $ tableBody enc xs tableHeadless attrs enc xs = tableEl attrs $ tableBody enc xs
tableBody :: Foldable f tableBody :: Foldable f
=> Encoding h (Cell site) a -- ^ How to encode data as a row => Colonnade h (Cell site) a -- ^ How to encode data as a row
-> f a -- ^ Rows of data -> f a -- ^ Rows of data
-> WidgetT site IO () -> WidgetT site IO ()
tableBody enc xs = tbody [] $ do tableBody enc xs = tbody [] $ do

4
yesod-colonnade/yesod-colonnade.cabal
View File

@ -1,5 +1,5 @@
name: yesod-colonnade name: yesod-colonnade
version: 0.1 version: 0.2
synopsis: Helper functions for using yesod with colonnade synopsis: Helper functions for using yesod with colonnade
description: Yesod and colonnade description: Yesod and colonnade
homepage: https://github.com/andrewthad/colonnade#readme homepage: https://github.com/andrewthad/colonnade#readme
@ -18,7 +18,7 @@ library
Yesod.Colonnade Yesod.Colonnade
build-depends: build-depends:
base >= 4.7 && < 5 base >= 4.7 && < 5
, colonnade >= 0.4.6 && < 0.5 , colonnade >= 0.5 && < 0.6
, yesod-core >= 1.4.0 && < 1.5 , yesod-core >= 1.4.0 && < 1.5
, text >= 1.0 && < 1.3 , text >= 1.0 && < 1.3
default-language: Haskell2010 default-language: Haskell2010