├── .gitignore ├── README.md ├── blaze-colonnade ├── LICENSE ├── Setup.hs ├── blaze-colonnade.cabal ├── hackage-docs.sh └── src │ └── Text │ └── Blaze │ └── Colonnade.hs ├── build ├── cabal.project ├── colonnade ├── LICENSE ├── Setup.hs ├── colonnade.cabal ├── hackage-docs.sh └── src │ ├── Colonnade.hs │ └── Colonnade │ └── Encode.hs ├── geolite-csv ├── LICENSE ├── Setup.hs ├── data │ └── small │ │ ├── GeoLite2-City-Blocks-IPv4.csv │ │ ├── GeoLite2-City-Locations-en.csv │ │ └── GeoLite2-City-Locations-ja.csv ├── geolite-csv.cabal ├── hackage-docs.sh ├── scripts │ └── load-full-databases ├── src │ └── Geolite │ │ ├── Csv.hs │ │ └── Types.hs └── test │ └── Spec.hs ├── lucid-colonnade ├── LICENSE ├── Setup.hs ├── lucid-colonnade.cabal └── src │ └── Lucid │ └── Colonnade.hs ├── projects ├── cabal-8.0.2.project ├── cabal-8.2.2.project └── cabal-8.4.3.project ├── siphon ├── CHANGELOG.md ├── LICENSE ├── Setup.hs ├── hackage-docs.sh ├── siphon.cabal ├── src │ ├── Siphon.hs │ └── Siphon │ │ ├── ByteString │ │ └── Char8.hs │ │ ├── Content.hs │ │ ├── Decoding.hs │ │ ├── Encoding.hs │ │ ├── Internal.hs │ │ ├── Internal │ │ └── Text.hs │ │ ├── Text.hs │ │ └── Types.hs └── test │ └── Test.hs └── yesod-colonnade ├── LICENSE ├── Setup.hs ├── hackage-docs.sh ├── src └── Yesod │ └── Colonnade.hs └── yesod-colonnade.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | *.aux 2 | cabal-dev 3 | .cabal-sandbox 4 | cabal.config 5 | cabal.sandbox.config 6 | *.chi 7 | *.chs.h 8 | dist* 9 | .DS_Store 10 | *.dyn_hi 11 | *.dyn_o 12 | *.hi 13 | *.hp 14 | .hpc 15 | .ghci 16 | .hsenv* 17 | *.o 18 | *.prof 19 | *.sqlite3 20 | *.swp 21 | .virtualenv 22 | .stack-work/ 23 | tmp/ 24 | **/*.dump-hi 25 | tags 26 | TAGS 27 | colonnade/ex1.hs 28 | colonnade/result 29 | 30 | reflex-dom-colonnade/result 31 | siphon-0.8.0-docs.tar.gz 32 | siphon-0.8.0-docs/ 33 | .ghc.environment.* 34 | example 35 | example.hs 36 | example1 37 | example1.hs 38 | client_session_key.aes 39 | cabal.project.local 40 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Most of the tests use doctest, which isn't run like a normal test suite (I guess). 2 | 3 | To run these tests, first make sure `doctest` is on the `PATH` (i.e. `cabal install doctest`), then run the following commands: 4 | 5 | ``` 6 | cabal repl --build-depends=QuickCheck --with-ghc=doctest --repl-options="-fno-warn-orphans" siphon 7 | cabal repl --build-depends=QuickCheck --with-ghc=doctest --repl-options="-fno-warn-orphans" colonnade 8 | cabal repl --build-depends=QuickCheck --with-ghc=doctest --repl-options="-fno-warn-orphans" blaze-colonnade 9 | ``` 10 | 11 | There are no tests for lucid-colonnade at present. 12 | -------------------------------------------------------------------------------- /blaze-colonnade/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Andrew Martin (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Andrew Martin nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /blaze-colonnade/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /blaze-colonnade/blaze-colonnade.cabal: -------------------------------------------------------------------------------- 1 | name: blaze-colonnade 2 | version: 1.2.2.1 3 | synopsis: blaze-html backend for colonnade 4 | description: 5 | This library provides a backend for using blaze-html with colonnade. 6 | It generates standard HTML tables with ``, ``, ``, 7 | ``, `
`, and ``. 8 | homepage: https://github.com/andrewthad/colonnade#readme 9 | license: BSD3 10 | license-file: LICENSE 11 | author: Andrew Martin 12 | maintainer: andrew.thaddeus@gmail.com 13 | copyright: 2017 Andrew Martin 14 | category: web 15 | build-type: Simple 16 | cabal-version: >=1.10 17 | 18 | -- Note: There is a dependency on profunctors whose only 19 | -- purpose is to make doctest work correctly. Since this 20 | -- library transitively depends on profunctors anyway, 21 | -- this is not a big deal. 22 | 23 | library 24 | hs-source-dirs: src 25 | exposed-modules: 26 | Text.Blaze.Colonnade 27 | build-depends: 28 | base >= 4.8 && < 5 29 | , colonnade >= 1.1 && < 1.3 30 | , blaze-markup >= 0.7 && < 0.9 31 | , blaze-html >= 0.8 && < 0.10 32 | , profunctors >= 5.0 && < 5.7 33 | , text >= 1.2 && < 2.1 34 | default-language: Haskell2010 35 | 36 | source-repository head 37 | type: git 38 | location: https://github.com/andrewthad/colonnade 39 | -------------------------------------------------------------------------------- /blaze-colonnade/hackage-docs.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | 4 | if [ "$#" -ne 1 ]; then 5 | echo "Usage: scripts/hackage-docs.sh HACKAGE_USER" 6 | exit 1 7 | fi 8 | 9 | user=$1 10 | 11 | cabal_file=$(find . -maxdepth 1 -name "*.cabal" -print -quit) 12 | if [ ! -f "$cabal_file" ]; then 13 | echo "Run this script in the top-level package directory" 14 | exit 1 15 | fi 16 | 17 | pkg=$(awk -F ":[[:space:]]*" 'tolower($1)=="name" { print $2 }' < "$cabal_file") 18 | ver=$(awk -F ":[[:space:]]*" 'tolower($1)=="version" { print $2 }' < "$cabal_file") 19 | 20 | if [ -z "$pkg" ]; then 21 | echo "Unable to determine package name" 22 | exit 1 23 | fi 24 | 25 | if [ -z "$ver" ]; then 26 | echo "Unable to determine package version" 27 | exit 1 28 | fi 29 | 30 | echo "Detected package: $pkg-$ver" 31 | 32 | dir=$(mktemp -d build-docs.XXXXXX) 33 | trap 'rm -r "$dir"' EXIT 34 | 35 | # cabal haddock --hoogle --hyperlink-source --html-location='/package/$pkg-$version/docs' --contents-location='/package/$pkg-$version' 36 | stack haddock 37 | 38 | cp -R .stack-work/dist/x86_64-linux/Cabal-1.22.5.0/doc/html/$pkg/ $dir/$pkg-$ver-docs 39 | # /home/andrew/.stack/snapshots/x86_64-linux/lts-5.17/7.10.3/doc/index.html 40 | 41 | tar cvz -C $dir --format=ustar -f $dir/$pkg-$ver-docs.tar.gz $pkg-$ver-docs 42 | 43 | curl -X PUT \ 44 | -H 'Content-Type: application/x-tar' \ 45 | -H 'Content-Encoding: gzip' \ 46 | -u "$user" \ 47 | --data-binary "@$dir/$pkg-$ver-docs.tar.gz" \ 48 | "https://hackage.haskell.org/package/$pkg-$ver/docs" 49 | -------------------------------------------------------------------------------- /blaze-colonnade/src/Text/Blaze/Colonnade.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | -- | Build HTML tables using @blaze-html@ and @colonnade@. The bottom 6 | -- of this page has a tutorial that walks through a full example, 7 | -- illustrating how to meet typical needs with this library. It is 8 | -- recommended that users read the documentation for @colonnade@ first, 9 | -- since this library builds on the abstractions introduced there. 10 | -- A concise example of this library\'s use: 11 | -- 12 | -- >>> :set -XOverloadedStrings 13 | -- >>> :module + Colonnade Text.Blaze.Html Text.Blaze.Colonnade 14 | -- >>> let col = headed "Grade" (toHtml . fst) <> headed "Letter" (toHtml . snd) 15 | -- >>> let rows = [("90-100",'A'),("80-89",'B'),("70-79",'C')] 16 | -- >>> printVeryCompactHtml (encodeHtmlTable mempty col rows) 17 | -- 18 | -- 19 | -- 20 | -- 21 | -- 22 | -- 23 | -- 24 | -- 25 | -- 26 | --
GradeLetter
90-100A
80-89B
70-79C
27 | module Text.Blaze.Colonnade 28 | ( -- * Apply 29 | encodeHtmlTable 30 | , encodeCellTable 31 | , encodeTable 32 | , encodeCappedTable 33 | -- * Cell 34 | -- $build 35 | , Cell(..) 36 | , htmlCell 37 | , stringCell 38 | , textCell 39 | , lazyTextCell 40 | , builderCell 41 | , htmlFromCell 42 | -- * Interactive 43 | , printCompactHtml 44 | , printVeryCompactHtml 45 | -- * Tutorial 46 | -- $setup 47 | 48 | -- * Discussion 49 | -- $discussion 50 | ) where 51 | 52 | import Text.Blaze (Attribute,(!)) 53 | import Text.Blaze.Html (Html, toHtml) 54 | import Colonnade (Colonnade,Headed,Headless,Fascia,Cornice) 55 | import Data.Text (Text) 56 | import Control.Monad 57 | import Data.Semigroup 58 | import Data.Monoid hiding ((<>)) 59 | import Data.Foldable 60 | import Data.String (IsString(..)) 61 | import Data.Maybe (listToMaybe) 62 | import Data.Char (isSpace) 63 | import qualified Data.List as List 64 | import qualified Text.Blaze.Html.Renderer.Pretty as Pretty 65 | import qualified Text.Blaze as Blaze 66 | import qualified Text.Blaze.Html5 as H 67 | import qualified Text.Blaze.Html5.Attributes as HA 68 | import qualified Colonnade.Encode as E 69 | import qualified Data.Text as Text 70 | import qualified Data.Text.Lazy as LText 71 | import qualified Data.Text.Lazy.Builder as TBuilder 72 | 73 | -- $setup 74 | -- We start with a few necessary imports and some example data 75 | -- types: 76 | -- 77 | -- >>> :set -XOverloadedStrings 78 | -- >>> import Data.Monoid (mconcat,(<>)) 79 | -- >>> import Data.Char (toLower) 80 | -- >>> import Data.Profunctor (Profunctor(lmap)) 81 | -- >>> import Colonnade (Colonnade,Headed,Headless,headed,cap,Fascia(..)) 82 | -- >>> import Text.Blaze.Html (Html, toHtml, toValue) 83 | -- >>> import qualified Text.Blaze.Html5 as H 84 | -- >>> data Department = Management | Sales | Engineering deriving (Show,Eq) 85 | -- >>> data Employee = Employee { name :: String, department :: Department, age :: Int } 86 | -- 87 | -- We define some employees that we will display in a table: 88 | -- 89 | -- >>> :{ 90 | -- let employees = 91 | -- [ Employee "Thaddeus" Sales 34 92 | -- , Employee "Lucia" Engineering 33 93 | -- , Employee "Pranav" Management 57 94 | -- ] 95 | -- :} 96 | -- 97 | -- Let's build a table that displays the name and the age 98 | -- of an employee. Additionally, we will emphasize the names of 99 | -- engineers using a @\@ tag. 100 | -- 101 | -- >>> :{ 102 | -- let tableEmpA :: Colonnade Headed Employee Html 103 | -- tableEmpA = mconcat 104 | -- [ headed "Name" $ \emp -> case department emp of 105 | -- Engineering -> H.strong (toHtml (name emp)) 106 | -- _ -> toHtml (name emp) 107 | -- , headed "Age" (toHtml . show . age) 108 | -- ] 109 | -- :} 110 | -- 111 | -- The type signature of @tableEmpA@ is inferrable but is written 112 | -- out for clarity in this example. Additionally, note that the first 113 | -- argument to 'headed' is of type 'Html', so @OverloadedStrings@ is 114 | -- necessary for the above example to compile. To avoid using this extension, 115 | -- it is possible to instead use 'toHtml' to convert a 'String' to 'Html'. 116 | -- Let\'s continue: 117 | -- 118 | -- >>> let customAttrs = HA.class_ "stylish-table" <> HA.id "main-table" 119 | -- >>> printCompactHtml (encodeHtmlTable customAttrs tableEmpA employees) 120 | -- 121 | -- 122 | -- 123 | -- 124 | -- 125 | -- 126 | -- 127 | -- 128 | -- 129 | -- 130 | -- 131 | -- 132 | -- 133 | -- 134 | -- 135 | -- 136 | -- 137 | -- 138 | -- 139 | -- 140 | -- 141 | --
NameAge
Thaddeus34
Lucia33
Pranav57
142 | -- 143 | -- Excellent. As expected, Lucia\'s name is wrapped in a @\@ tag 144 | -- since she is an engineer. 145 | -- 146 | -- One limitation of using 'Html' as the content 147 | -- type of a 'Colonnade' is that we are unable to add attributes to 148 | -- the @\@ and @\@ elements. This library provides the 'Cell' type 149 | -- to work around this problem. A 'Cell' is just 'Html' content and a set 150 | -- of attributes to be applied to its parent @		@ or @@. To illustrate 151 | -- how its use, another employee table will be built. This table will 152 | -- contain a single column indicating the department of each employ. Each 153 | -- cell will be assigned a class name based on the department. To start off, 154 | -- let\'s build a table that encodes departments: 155 | -- 156 | -- >>> :{ 157 | -- let tableDept :: Colonnade Headed Department Cell 158 | -- tableDept = mconcat 159 | -- [ headed "Dept." $ \d -> Cell 160 | -- (HA.class_ (toValue (map toLower (show d)))) 161 | -- (toHtml (show d)) 162 | -- ] 163 | -- :} 164 | -- 165 | -- Again, @OverloadedStrings@ plays a role, this time allowing the 166 | -- literal @"Dept."@ to be accepted as a value of type 'Cell'. To avoid 167 | -- this extension, 'stringCell' could be used to upcast the 'String'. 168 | -- To try out our 'Colonnade' on a list of departments, we need to use 169 | -- 'encodeCellTable' instead of 'encodeHtmlTable': 170 | -- 171 | -- >>> let twoDepts = [Sales,Management] 172 | -- >>> printVeryCompactHtml (encodeCellTable customAttrs tableDept twoDepts) 173 | -- 174 | -- 175 | -- 176 | -- 177 | -- 178 | -- 179 | -- 180 | -- 181 | --
Dept.
Sales
Management
182 | -- 183 | -- The attributes on the @\@ elements show up as they are expected to. 184 | -- Now, we take advantage of the @Profunctor@ instance of 'Colonnade' to allow 185 | -- this to work on @Employee@\'s instead: 186 | -- 187 | -- >>> :t lmap 188 | -- lmap :: Profunctor p => (a -> b) -> p b c -> p a c 189 | -- >>> let tableEmpB = lmap department tableDept 190 | -- >>> :t tableEmpB 191 | -- tableEmpB :: Colonnade Headed Employee Cell 192 | -- >>> printVeryCompactHtml (encodeCellTable customAttrs tableEmpB employees) 193 | -- 194 | -- 195 | -- 196 | -- 197 | -- 198 | -- 199 | -- 200 | -- 201 | -- 202 | --
Dept.
Sales
Engineering
Management
203 | -- 204 | -- This table shows the department of each of our three employees, additionally 205 | -- making a lowercased version of the department into a class name for the @\@. 206 | -- This table is nice for illustrative purposes, but it does not provide all the 207 | -- information that we have about the employees. If we combine it with the 208 | -- earlier table we wrote, we can present everything in the table. One small 209 | -- roadblock is that the types of @tableEmpA@ and @tableEmpB@ do not match, which 210 | -- prevents a straightforward monoidal append: 211 | -- 212 | -- >>> :t tableEmpA 213 | -- tableEmpA :: Colonnade Headed Employee Html 214 | -- >>> :t tableEmpB 215 | -- tableEmpB :: Colonnade Headed Employee Cell 216 | -- 217 | -- We can upcast the content type with 'fmap'. 218 | -- Monoidal append is then well-typed, and the resulting 'Colonnade' 219 | -- can be applied to the employees: 220 | -- 221 | -- >>> let tableEmpC = fmap htmlCell tableEmpA <> tableEmpB 222 | -- >>> :t tableEmpC 223 | -- tableEmpC :: Colonnade Headed Employee Cell 224 | -- >>> printCompactHtml (encodeCellTable customAttrs tableEmpC employees) 225 | -- 226 | -- 227 | -- 228 | -- 229 | -- 230 | -- 231 | -- 232 | -- 233 | -- 234 | -- 235 | -- 236 | -- 237 | -- 238 | -- 239 | -- 240 | -- 241 | -- 242 | -- 243 | -- 244 | -- 245 | -- 246 | -- 247 | -- 248 | -- 249 | -- 250 | --
NameAgeDept.
Thaddeus34Sales
Lucia33Engineering
Pranav57Management
251 | 252 | -- $build 253 | -- 254 | -- The 'Cell' type is used to build a 'Colonnade' that 255 | -- has 'Html' content inside table cells and may optionally 256 | -- have attributes added to the @\@ or @\@ elements 257 | -- that wrap this HTML content. 258 | 259 | -- | The attributes that will be applied to a @\@ and 260 | -- the HTML content that will go inside it. When using 261 | -- this type, remember that 'Attribute', defined in @blaze-markup@, 262 | -- is actually a collection of attributes, not a single attribute. 263 | data Cell = Cell 264 | { cellAttribute :: !Attribute 265 | , cellHtml :: !Html 266 | } 267 | 268 | instance IsString Cell where 269 | fromString = stringCell 270 | 271 | instance Semigroup Cell where 272 | (Cell a1 c1) <> (Cell a2 c2) = Cell (a1 <> a2) (c1 <> c2) 273 | 274 | instance Monoid Cell where 275 | mempty = Cell mempty mempty 276 | mappend = (<>) 277 | 278 | -- | Create a 'Cell' from a 'Widget' 279 | htmlCell :: Html -> Cell 280 | htmlCell = Cell mempty 281 | 282 | -- | Create a 'Cell' from a 'String' 283 | stringCell :: String -> Cell 284 | stringCell = htmlCell . fromString 285 | 286 | -- | Create a 'Cell' from a 'Char' 287 | charCell :: Char -> Cell 288 | charCell = stringCell . pure 289 | 290 | -- | Create a 'Cell' from a 'Text' 291 | textCell :: Text -> Cell 292 | textCell = htmlCell . toHtml 293 | 294 | -- | Create a 'Cell' from a lazy text 295 | lazyTextCell :: LText.Text -> Cell 296 | lazyTextCell = textCell . LText.toStrict 297 | 298 | -- | Create a 'Cell' from a text builder 299 | builderCell :: TBuilder.Builder -> Cell 300 | builderCell = lazyTextCell . TBuilder.toLazyText 301 | 302 | -- | Encode a table. This handles a very general case and 303 | -- is seldom needed by users. One of the arguments provided is 304 | -- used to add attributes to the generated @\@ elements. 305 | encodeTable :: forall h f a c. (Foldable f, E.Headedness h) 306 | => h (Attribute,Attribute) -- ^ Attributes of @\@ and its @\@, pass 'Nothing' to omit @\@ 307 | -> Attribute -- ^ Attributes of @\@ element 308 | -> (a -> Attribute) -- ^ Attributes of each @\@ element 309 | -> ((Html -> Html) -> c -> Html) -- ^ Wrap content and convert to 'Html' 310 | -> Attribute -- ^ Attributes of @\@ element 311 | -> Colonnade h a c -- ^ How to encode data as a row 312 | -> f a -- ^ Collection of data 313 | -> Html 314 | encodeTable mtheadAttrs tbodyAttrs trAttrs wrapContent tableAttrs colonnade xs = 315 | H.table ! tableAttrs $ do 316 | case E.headednessExtractForall of 317 | Nothing -> return mempty 318 | Just extractForall -> do 319 | let (theadAttrs,theadTrAttrs) = extract mtheadAttrs 320 | H.thead ! theadAttrs $ H.tr ! theadTrAttrs $ do 321 | -- E.headerMonoidalGeneral colonnade (wrapContent H.th) 322 | foldlMapM' (wrapContent H.th . extract . E.oneColonnadeHead) (E.getColonnade colonnade) 323 | where 324 | extract :: forall y. h y -> y 325 | extract = E.runExtractForall extractForall 326 | encodeBody trAttrs wrapContent tbodyAttrs colonnade xs 327 | 328 | foldlMapM' :: forall g b a m. (Foldable g, Monoid b, Monad m) => (a -> m b) -> g a -> m b 329 | foldlMapM' f xs = foldr f' pure xs mempty 330 | where 331 | f' :: a -> (b -> m b) -> b -> m b 332 | f' x k bl = do 333 | br <- f x 334 | let !b = mappend bl br 335 | k b 336 | 337 | -- | Encode a table with tiered header rows. 338 | -- >>> let cor = mconcat [cap "Personal" (fmap htmlCell tableEmpA), cap "Work" tableEmpB] 339 | -- >>> let fascia = FasciaCap (HA.class_ "category") (FasciaBase (HA.class_ "subcategory")) 340 | -- >>> printCompactHtml (encodeCappedCellTable mempty fascia cor [head employees]) 341 | -- 342 | -- 343 | -- 344 | -- 345 | -- 346 | -- 347 | -- 348 | -- 349 | -- 350 | -- 351 | -- 352 | -- 353 | -- 354 | -- 355 | -- 356 | -- 357 | -- 358 | -- 359 | -- 360 | --
PersonalWork
NameAgeDept.
Thaddeus34Sales
361 | 362 | encodeCappedCellTable :: Foldable f 363 | => Attribute -- ^ Attributes of @\@ element 364 | -> Fascia p Attribute -- ^ Attributes for @\@ elements in the @\@ 365 | -> Cornice Headed p a Cell 366 | -> f a -- ^ Collection of data 367 | -> Html 368 | encodeCappedCellTable = encodeCappedTable mempty mempty (const mempty) htmlFromCell 369 | 370 | -- | Encode a table with tiered header rows. This is the most general function 371 | -- in this library for encoding a 'Cornice'. 372 | -- 373 | encodeCappedTable :: Foldable f 374 | => Attribute -- ^ Attributes of @\@ 375 | -> Attribute -- ^ Attributes of @\@ element 376 | -> (a -> Attribute) -- ^ Attributes of each @\@ element in the @\@ 377 | -> ((Html -> Html) -> c -> Html) -- ^ Wrap content and convert to 'Html' 378 | -> Attribute -- ^ Attributes of @\@ element 379 | -> Fascia p Attribute -- ^ Attributes for @\@ elements in the @\@ 380 | -> Cornice Headed p a c 381 | -> f a -- ^ Collection of data 382 | -> Html 383 | encodeCappedTable theadAttrs tbodyAttrs trAttrs wrapContent tableAttrs fascia cornice xs = do 384 | let colonnade = E.discard cornice 385 | annCornice = E.annotate cornice 386 | H.table ! tableAttrs $ do 387 | H.thead ! theadAttrs $ do 388 | E.headersMonoidal 389 | (Just (fascia, \attrs theHtml -> H.tr ! attrs $ theHtml)) 390 | [ ( \msz c -> case msz of 391 | Just sz -> wrapContent H.th c ! HA.colspan (H.toValue (show sz)) 392 | Nothing -> mempty 393 | , id 394 | ) 395 | ] 396 | annCornice 397 | -- H.tr ! trAttrs $ do 398 | -- E.headerMonoidalGeneral colonnade (wrapContent H.th) 399 | encodeBody trAttrs wrapContent tbodyAttrs colonnade xs 400 | 401 | encodeBody :: Foldable f 402 | => (a -> Attribute) -- ^ Attributes of each @\@ element 403 | -> ((Html -> Html) -> c -> Html) -- ^ Wrap content and convert to 'Html' 404 | -> Attribute -- ^ Attributes of @\@ element 405 | -> Colonnade h a c -- ^ How to encode data as a row 406 | -> f a -- ^ Collection of data 407 | -> Html 408 | encodeBody trAttrs wrapContent tbodyAttrs colonnade xs = do 409 | H.tbody ! tbodyAttrs $ do 410 | forM_ xs $ \x -> do 411 | H.tr ! trAttrs x $ E.rowMonoidal colonnade (wrapContent H.td) x 412 | 413 | 414 | -- | Encode a table. Table cells may have attributes 415 | -- applied to them. 416 | encodeCellTable :: 417 | Foldable f 418 | => Attribute -- ^ Attributes of @\@ element 419 | -> Colonnade Headed a Cell -- ^ How to encode data as columns 420 | -> f a -- ^ Collection of data 421 | -> Html 422 | encodeCellTable = encodeTable 423 | (E.headednessPure (mempty,mempty)) mempty (const mempty) htmlFromCell 424 | 425 | -- | Encode a table. Table cell element do not have 426 | -- any attributes applied to them. 427 | encodeHtmlTable :: 428 | (Foldable f, E.Headedness h) 429 | => Attribute -- ^ Attributes of @\@ element 430 | -> Colonnade h a Html -- ^ How to encode data as columns 431 | -> f a -- ^ Collection of data 432 | -> Html 433 | encodeHtmlTable = encodeTable 434 | (E.headednessPure (mempty,mempty)) mempty (const mempty) ($) 435 | 436 | -- | Convert a 'Cell' to 'Html' by wrapping the content with a tag 437 | -- and applying the 'Cell' attributes to that tag. 438 | htmlFromCell :: (Html -> Html) -> Cell -> Html 439 | htmlFromCell f (Cell attr content) = f ! attr $ content 440 | 441 | data St = St 442 | { stContext :: [String] 443 | , stTagStatus :: TagStatus 444 | , stResult :: String -> String -- ^ difference list 445 | } 446 | 447 | data TagStatus 448 | = TagStatusSomeTag 449 | | TagStatusOpening (String -> String) 450 | | TagStatusOpeningAttrs 451 | | TagStatusNormal 452 | | TagStatusClosing (String -> String) 453 | | TagStatusAfterTag 454 | 455 | removeWhitespaceAfterTag :: String -> String -> String 456 | removeWhitespaceAfterTag chosenTag = 457 | either id (\st -> stResult st "") . foldlM (flip f) (St [] TagStatusNormal id) 458 | where 459 | f :: Char -> St -> Either String St 460 | f c (St ctx status res) = case status of 461 | TagStatusNormal 462 | | c == '<' -> Right (St ctx TagStatusSomeTag likelyRes) 463 | | isSpace c -> if Just chosenTag == listToMaybe ctx 464 | then Right (St ctx TagStatusNormal res) -- drops the whitespace 465 | else Right (St ctx TagStatusNormal likelyRes) 466 | | otherwise -> Right (St ctx TagStatusNormal likelyRes) 467 | TagStatusSomeTag 468 | | c == '/' -> Right (St ctx (TagStatusClosing id) likelyRes) 469 | | c == '>' -> Left "unexpected >" 470 | | c == '<' -> Left "unexpected <" 471 | | otherwise -> Right (St ctx (TagStatusOpening (c:)) likelyRes) 472 | TagStatusOpening tag 473 | | c == '>' -> Right (St (tag "" : ctx) TagStatusAfterTag likelyRes) 474 | | isSpace c -> Right (St (tag "" : ctx) TagStatusOpeningAttrs likelyRes) 475 | | otherwise -> Right (St ctx (TagStatusOpening (tag . (c:))) likelyRes) 476 | TagStatusOpeningAttrs 477 | | c == '>' -> Right (St ctx TagStatusAfterTag likelyRes) 478 | | otherwise -> Right (St ctx TagStatusOpeningAttrs likelyRes) 479 | TagStatusClosing tag 480 | | c == '>' -> do 481 | otherTags <- case ctx of 482 | [] -> Left "closing tag without any opening tag" 483 | closestTag : otherTags -> if closestTag == tag "" 484 | then Right otherTags 485 | else Left $ "closing tag <" ++ tag "" ++ "> did not match opening tag <" ++ closestTag ++ ">" 486 | Right (St otherTags TagStatusAfterTag likelyRes) 487 | | otherwise -> Right (St ctx (TagStatusClosing (tag . (c:))) likelyRes) 488 | TagStatusAfterTag 489 | | c == '<' -> Right (St ctx TagStatusSomeTag likelyRes) 490 | | isSpace c -> if Just chosenTag == listToMaybe ctx 491 | then Right (St ctx TagStatusAfterTag res) -- drops the whitespace 492 | else Right (St ctx TagStatusNormal likelyRes) 493 | | otherwise -> Right (St ctx TagStatusNormal likelyRes) 494 | where 495 | likelyRes :: String -> String 496 | likelyRes = res . (c:) 497 | 498 | -- | Pretty print an HTML table, stripping whitespace from inside @\@, 499 | -- @\@, and common inline tags. The implementation is inefficient and is 500 | -- incorrect in many corner cases. It is only provided to reduce the line 501 | -- count of the HTML printed by GHCi examples in this module\'s documentation. 502 | -- Use of this function is discouraged. 503 | printCompactHtml :: Html -> IO () 504 | printCompactHtml = putStrLn 505 | . List.dropWhileEnd (== '\n') 506 | . removeWhitespaceAfterTag "td" 507 | . removeWhitespaceAfterTag "th" 508 | . removeWhitespaceAfterTag "strong" 509 | . removeWhitespaceAfterTag "span" 510 | . removeWhitespaceAfterTag "em" 511 | . Pretty.renderHtml 512 | 513 | -- | Similar to 'printCompactHtml'. Additionally strips all whitespace inside 514 | -- @\@ elements and @\@ elements. 515 | printVeryCompactHtml :: Html -> IO () 516 | printVeryCompactHtml = putStrLn 517 | . List.dropWhileEnd (== '\n') 518 | . removeWhitespaceAfterTag "td" 519 | . removeWhitespaceAfterTag "th" 520 | . removeWhitespaceAfterTag "strong" 521 | . removeWhitespaceAfterTag "span" 522 | . removeWhitespaceAfterTag "em" 523 | . removeWhitespaceAfterTag "tr" 524 | . Pretty.renderHtml 525 | 526 | 527 | -- $discussion 528 | -- 529 | -- In this module, some of the functions for applying a 'Colonnade' to 530 | -- some values to build a table have roughly this type signature: 531 | -- 532 | -- > Foldable a => Colonnade Headedness Cell a -> f a -> Html 533 | -- 534 | -- The 'Colonnade' content type is 'Cell', but the content 535 | -- type of the result is 'Html'. It may not be immidiately clear why 536 | -- this is useful done. Another strategy, which this library also 537 | -- uses, is to write 538 | -- these functions to take a 'Colonnade' whose content is 'Html': 539 | -- 540 | -- > Foldable a => Colonnade Headedness Html a -> f a -> Html 541 | -- 542 | -- When the 'Colonnade' content type is 'Html', then the header 543 | -- content is rendered as the child of a @\@ and the row 544 | -- content the child of a @\@. However, it is not possible 545 | -- to add attributes to these parent elements. To accomodate this 546 | -- situation, it is necessary to introduce 'Cell', which includes 547 | -- the possibility of attributes on the parent node. 548 | 549 | 550 | -------------------------------------------------------------------------------- /build: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | 4 | # To use this script on Ubuntu, you will need to first run the following: 5 | # 6 | # sudo apt install ghc-7.4.2 ghc-7.6.3 ghc-7.8.4 ghc-7.10.3 ghc-8.0.2 ghc-8.2.2 ghc-8.4.3 ghc-8.6.1 7 | 8 | declare -a ghcs=("7.10.3" "8.0.2" "8.2.2" "8.4.4" "8.6.5") 9 | 10 | ## now loop through the above array 11 | for g in "${ghcs[@]}" 12 | do 13 | cabal new-build --builddir "dist-$g" -w "/opt/ghc/bin/ghc-$g" colonnade 14 | cabal new-build --builddir "dist-$g" -w "/opt/ghc/bin/ghc-$g" siphon 15 | done 16 | 17 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: ./colonnade 2 | ./blaze-colonnade 3 | ./lucid-colonnade 4 | ./siphon 5 | ./yesod-colonnade 6 | -------------------------------------------------------------------------------- /colonnade/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Andrew Martin (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Andrew Martin nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /colonnade/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /colonnade/colonnade.cabal: -------------------------------------------------------------------------------- 1 | name: colonnade 2 | version: 1.2.0.2 3 | synopsis: Generic types and functions for columnar encoding and decoding 4 | description: 5 | The `colonnade` package provides a way to talk about 6 | columnar encodings and decodings of data. This package provides 7 | very general types and does not provide a way for the end-user 8 | to actually apply the columnar encodings they build to data. 9 | Most users will also want to one a companion packages 10 | that provides (1) a content type and (2) functions for feeding 11 | data into a columnar encoding: 12 | . 13 | * for `lucid` html tables 14 | . 15 | * for `blaze` html tables 16 | . 17 | * for reactive `reflex-dom` tables 18 | . 19 | * for `yesod` widgets 20 | . 21 | * for encoding and decoding CSVs 22 | homepage: https://github.com/andrewthad/colonnade#readme 23 | license: BSD3 24 | license-file: LICENSE 25 | author: Andrew Martin 26 | maintainer: andrew.thaddeus@gmail.com 27 | copyright: 2016 Andrew Martin 28 | category: web 29 | build-type: Simple 30 | cabal-version: >=1.10 31 | 32 | library 33 | hs-source-dirs: src 34 | exposed-modules: 35 | Colonnade 36 | Colonnade.Encode 37 | build-depends: 38 | base >= 4.12 && < 5 39 | , contravariant >= 1.2 && < 1.6 40 | , vector >= 0.10 && < 0.14 41 | , text >= 1.0 && < 2.2 42 | , bytestring >= 0.10 && < 0.12 43 | , profunctors >= 5.0 && < 5.7 44 | , semigroups >= 0.18.2 && < 0.21 45 | default-language: Haskell2010 46 | ghc-options: -Wall 47 | 48 | source-repository head 49 | type: git 50 | location: https://github.com/andrewthad/colonnade 51 | -------------------------------------------------------------------------------- /colonnade/hackage-docs.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | 4 | if [ "$#" -ne 1 ]; then 5 | echo "Usage: scripts/hackage-docs.sh HACKAGE_USER" 6 | exit 1 7 | fi 8 | 9 | user=$1 10 | 11 | cabal_file=$(find . -maxdepth 1 -name "*.cabal" -print -quit) 12 | if [ ! -f "$cabal_file" ]; then 13 | echo "Run this script in the top-level package directory" 14 | exit 1 15 | fi 16 | 17 | pkg=$(awk -F ":[[:space:]]*" 'tolower($1)=="name" { print $2 }' < "$cabal_file") 18 | ver=$(awk -F ":[[:space:]]*" 'tolower($1)=="version" { print $2 }' < "$cabal_file") 19 | 20 | if [ -z "$pkg" ]; then 21 | echo "Unable to determine package name" 22 | exit 1 23 | fi 24 | 25 | if [ -z "$ver" ]; then 26 | echo "Unable to determine package version" 27 | exit 1 28 | fi 29 | 30 | echo "Detected package: $pkg-$ver" 31 | 32 | dir=$(mktemp -d build-docs.XXXXXX) 33 | trap 'rm -r "$dir"' EXIT 34 | 35 | # cabal haddock --hoogle --hyperlink-source --html-location='/package/$pkg-$version/docs' --contents-location='/package/$pkg-$version' 36 | stack haddock 37 | 38 | cp -R .stack-work/dist/x86_64-linux/Cabal-1.22.5.0/doc/html/$pkg/ $dir/$pkg-$ver-docs 39 | # /home/andrew/.stack/snapshots/x86_64-linux/lts-5.17/7.10.3/doc/index.html 40 | 41 | tar cvz -C $dir --format=ustar -f $dir/$pkg-$ver-docs.tar.gz $pkg-$ver-docs 42 | 43 | curl -X PUT \ 44 | -H 'Content-Type: application/x-tar' \ 45 | -H 'Content-Encoding: gzip' \ 46 | -u "$user" \ 47 | --data-binary "@$dir/$pkg-$ver-docs.tar.gz" \ 48 | "https://hackage.haskell.org/package/$pkg-$ver/docs" 49 | -------------------------------------------------------------------------------- /colonnade/src/Colonnade.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | 4 | {-# OPTIONS_GHC -Wall -fno-warn-unused-imports -fno-warn-unticked-promoted-constructors #-} 5 | 6 | -- | Build backend-agnostic columnar encodings that can be 7 | -- used to visualize tabular data. 8 | module Colonnade 9 | ( -- * Example 10 | -- $setup 11 | -- * Types 12 | Colonnade 13 | , Headed(..) 14 | , Headless(..) 15 | -- * Typeclasses 16 | , E.Headedness(..) 17 | -- * Create 18 | , headed 19 | , headless 20 | , singleton 21 | -- * Transform 22 | -- ** Body 23 | , fromMaybe 24 | , columns 25 | , bool 26 | , replaceWhen 27 | , modifyWhen 28 | -- ** Header 29 | , mapHeaderContent 30 | , mapHeadedness 31 | , toHeadless 32 | -- * Cornice 33 | -- ** Types 34 | , Cornice 35 | , Pillar(..) 36 | , Fascia(..) 37 | -- ** Create 38 | , cap 39 | , recap 40 | -- * Ascii Table 41 | , ascii 42 | , asciiCapped 43 | ) where 44 | 45 | import Colonnade.Encode (Colonnade,Cornice, 46 | Pillar(..),Fascia(..),Headed(..),Headless(..)) 47 | import Data.Foldable 48 | import Control.Monad 49 | import qualified Data.Bool 50 | import qualified Data.Maybe 51 | import qualified Colonnade.Encode as E 52 | import qualified Data.List as List 53 | import qualified Data.Vector as Vector 54 | 55 | -- $setup 56 | -- 57 | -- First, let\'s bring in some neccessary imports that will be 58 | -- used for the remainder of the examples in the docs: 59 | -- 60 | -- >>> import Data.Monoid (mconcat,(<>)) 61 | -- >>> import Data.Profunctor (lmap) 62 | -- 63 | -- The data types we wish to encode are: 64 | -- 65 | -- >>> data Color = Red | Green | Blue deriving (Show,Eq) 66 | -- >>> data Person = Person { name :: String, age :: Int } 67 | -- >>> data House = House { color :: Color, price :: Int } 68 | -- 69 | -- One potential columnar encoding of a @Person@ would be: 70 | -- 71 | -- >>> :{ 72 | -- let colPerson :: Colonnade Headed Person String 73 | -- colPerson = mconcat 74 | -- [ headed "Name" name 75 | -- , headed "Age" (show . age) 76 | -- ] 77 | -- :} 78 | -- 79 | -- The type signature on @colPerson@ is not neccessary 80 | -- but is included for clarity. We can feed data into this encoding 81 | -- to build a table: 82 | -- 83 | -- >>> let people = [Person "David" 63, Person "Ava" 34, Person "Sonia" 12] 84 | -- >>> putStr (ascii colPerson people) 85 | -- +-------+-----+ 86 | -- | Name | Age | 87 | -- +-------+-----+ 88 | -- | David | 63 | 89 | -- | Ava | 34 | 90 | -- | Sonia | 12 | 91 | -- +-------+-----+ 92 | -- 93 | -- Similarly, we can build a table of houses with: 94 | -- 95 | -- >>> let showDollar = (('$':) . show) :: Int -> String 96 | -- >>> colHouse = mconcat [headed "Color" (show . color), headed "Price" (showDollar . price)] 97 | -- >>> :t colHouse 98 | -- colHouse :: Colonnade Headed House String 99 | -- >>> let houses = [House Green 170000, House Blue 115000, House Green 150000] 100 | -- >>> putStr (ascii colHouse houses) 101 | -- +-------+---------+ 102 | -- | Color | Price | 103 | -- +-------+---------+ 104 | -- | Green | $170000 | 105 | -- | Blue | $115000 | 106 | -- | Green | $150000 | 107 | -- +-------+---------+ 108 | 109 | 110 | -- | A single column with a header. 111 | headed :: c -> (a -> c) -> Colonnade Headed a c 112 | headed h = singleton (Headed h) 113 | 114 | -- | A single column without a header. 115 | headless :: (a -> c) -> Colonnade Headless a c 116 | headless = singleton Headless 117 | 118 | -- | A single column with any kind of header. This is not typically needed. 119 | singleton :: h c -> (a -> c) -> Colonnade h a c 120 | singleton h = E.Colonnade . Vector.singleton . E.OneColonnade h 121 | 122 | -- | Map over the content in the header. This is similar performing 'fmap' 123 | -- on a 'Colonnade' except that the body content is unaffected. 124 | mapHeaderContent :: Functor h => (c -> c) -> Colonnade h a c -> Colonnade h a c 125 | mapHeaderContent f (E.Colonnade v) = 126 | E.Colonnade (Vector.map (\(E.OneColonnade h e) -> E.OneColonnade (fmap f h) e) v) 127 | 128 | -- | Map over the header type of a 'Colonnade'. 129 | mapHeadedness :: (forall x. h x -> h' x) -> Colonnade h a c -> Colonnade h' a c 130 | mapHeadedness f (E.Colonnade v) = 131 | E.Colonnade (Vector.map (\(E.OneColonnade h e) -> E.OneColonnade (f h) e) v) 132 | 133 | -- | Remove the heading from a 'Colonnade'. 134 | toHeadless :: Colonnade h a c -> Colonnade Headless a c 135 | toHeadless = mapHeadedness (const Headless) 136 | 137 | 138 | -- | Lift a column over a 'Maybe'. For example, if some people 139 | -- have houses and some do not, the data that pairs them together 140 | -- could be represented as: 141 | -- 142 | -- >>> :{ 143 | -- let owners :: [(Person,Maybe House)] 144 | -- owners = 145 | -- [ (Person "Jordan" 18, Nothing) 146 | -- , (Person "Ruth" 25, Just (House Red 125000)) 147 | -- , (Person "Sonia" 12, Just (House Green 145000)) 148 | -- ] 149 | -- :} 150 | -- 151 | -- The column encodings defined earlier can be reused with 152 | -- the help of 'fromMaybe': 153 | -- 154 | -- >>> :{ 155 | -- let colOwners :: Colonnade Headed (Person,Maybe House) String 156 | -- colOwners = mconcat 157 | -- [ lmap fst colPerson 158 | -- , lmap snd (fromMaybe "" colHouse) 159 | -- ] 160 | -- :} 161 | -- 162 | -- >>> putStr (ascii colOwners owners) 163 | -- +--------+-----+-------+---------+ 164 | -- | Name | Age | Color | Price | 165 | -- +--------+-----+-------+---------+ 166 | -- | Jordan | 18 | | | 167 | -- | Ruth | 25 | Red | $125000 | 168 | -- | Sonia | 12 | Green | $145000 | 169 | -- +--------+-----+-------+---------+ 170 | fromMaybe :: c -> Colonnade f a c -> Colonnade f (Maybe a) c 171 | fromMaybe c (E.Colonnade v) = E.Colonnade $ flip Vector.map v $ 172 | \(E.OneColonnade h encode) -> E.OneColonnade h (maybe c encode) 173 | 174 | -- | Convert a collection of @b@ values into a columnar encoding of 175 | -- the same size. Suppose we decide to show a house\'s color 176 | -- by putting a check mark in the column corresponding to 177 | -- the color instead of by writing out the name of the color: 178 | -- 179 | -- >>> let allColors = [Red,Green,Blue] 180 | -- >>> let encColor = columns (\c1 c2 -> if c1 == c2 then "✓" else "") (Headed . show) allColors 181 | -- >>> :t encColor 182 | -- encColor :: Colonnade Headed Color String 183 | -- >>> let encHouse = headed "Price" (showDollar . price) <> lmap color encColor 184 | -- >>> :t encHouse 185 | -- encHouse :: Colonnade Headed House String 186 | -- >>> putStr (ascii encHouse houses) 187 | -- +---------+-----+-------+------+ 188 | -- | Price | Red | Green | Blue | 189 | -- +---------+-----+-------+------+ 190 | -- | $170000 | | ✓ | | 191 | -- | $115000 | | | ✓ | 192 | -- | $150000 | | ✓ | | 193 | -- +---------+-----+-------+------+ 194 | columns :: Foldable g 195 | => (b -> a -> c) -- ^ Cell content function 196 | -> (b -> f c) -- ^ Header content function 197 | -> g b -- ^ Basis for column encodings 198 | -> Colonnade f a c 199 | columns getCell getHeader = id 200 | . E.Colonnade 201 | . Vector.map (\b -> E.OneColonnade (getHeader b) (getCell b)) 202 | . Vector.fromList 203 | . toList 204 | 205 | bool :: 206 | f c -- ^ Heading 207 | -> (a -> Bool) -- ^ Predicate 208 | -> (a -> c) -- ^ Contents when predicate is false 209 | -> (a -> c) -- ^ Contents when predicate is true 210 | -> Colonnade f a c 211 | bool h p onTrue onFalse = singleton h (Data.Bool.bool <$> onFalse <*> onTrue <*> p) 212 | 213 | -- | Modify the contents of cells in rows whose values satisfy the 214 | -- given predicate. Header content is unaffected. With an HTML backend, 215 | -- this can be used to strikethrough the contents of cells with data that is 216 | -- considered invalid. 217 | modifyWhen :: 218 | (c -> c) -- ^ Content change 219 | -> (a -> Bool) -- ^ Row predicate 220 | -> Colonnade f a c -- ^ Original 'Colonnade' 221 | -> Colonnade f a c 222 | modifyWhen changeContent p (E.Colonnade v) = E.Colonnade 223 | ( Vector.map 224 | (\(E.OneColonnade h encode) -> E.OneColonnade h $ \a -> 225 | if p a then changeContent (encode a) else encode a 226 | ) v 227 | ) 228 | 229 | -- | Replace the contents of cells in rows whose values satisfy the 230 | -- given predicate. Header content is unaffected. 231 | replaceWhen :: 232 | c -- ^ New content 233 | -> (a -> Bool) -- ^ Row predicate 234 | -> Colonnade f a c -- ^ Original 'Colonnade' 235 | -> Colonnade f a c 236 | replaceWhen = modifyWhen . const 237 | 238 | -- | Augment a 'Colonnade' with a header spans over all of the 239 | -- existing headers. This is best demonstrated by example. 240 | -- Let\'s consider how we might encode a pairing of the people 241 | -- and houses from the initial example: 242 | -- 243 | -- >>> let personHomePairs = zip people houses 244 | -- >>> let colPersonFst = lmap fst colPerson 245 | -- >>> let colHouseSnd = lmap snd colHouse 246 | -- >>> putStr (ascii (colPersonFst <> colHouseSnd) personHomePairs) 247 | -- +-------+-----+-------+---------+ 248 | -- | Name | Age | Color | Price | 249 | -- +-------+-----+-------+---------+ 250 | -- | David | 63 | Green | $170000 | 251 | -- | Ava | 34 | Blue | $115000 | 252 | -- | Sonia | 12 | Green | $150000 | 253 | -- +-------+-----+-------+---------+ 254 | -- 255 | -- This tabular encoding leaves something to be desired. The heading 256 | -- not indicate that the name and age refer to a person and that 257 | -- the color and price refer to a house. Without reaching for 'Cornice', 258 | -- we can still improve this situation with 'mapHeaderContent': 259 | -- 260 | -- >>> let colPersonFst' = mapHeaderContent ("Person " ++) colPersonFst 261 | -- >>> let colHouseSnd' = mapHeaderContent ("House " ++) colHouseSnd 262 | -- >>> putStr (ascii (colPersonFst' <> colHouseSnd') personHomePairs) 263 | -- +-------------+------------+-------------+-------------+ 264 | -- | Person Name | Person Age | House Color | House Price | 265 | -- +-------------+------------+-------------+-------------+ 266 | -- | David | 63 | Green | $170000 | 267 | -- | Ava | 34 | Blue | $115000 | 268 | -- | Sonia | 12 | Green | $150000 | 269 | -- +-------------+------------+-------------+-------------+ 270 | -- 271 | -- This is much better, but for longer tables, the redundancy 272 | -- of prefixing many column headers can become annoying. The solution 273 | -- that a 'Cornice' offers is to nest headers: 274 | -- 275 | -- >>> let cor = mconcat [cap "Person" colPersonFst, cap "House" colHouseSnd] 276 | -- >>> :t cor 277 | -- cor :: Cornice Headed ('Cap 'Base) (Person, House) String 278 | -- >>> putStr (asciiCapped cor personHomePairs) 279 | -- +-------------+-----------------+ 280 | -- | Person | House | 281 | -- +-------+-----+-------+---------+ 282 | -- | Name | Age | Color | Price | 283 | -- +-------+-----+-------+---------+ 284 | -- | David | 63 | Green | $170000 | 285 | -- | Ava | 34 | Blue | $115000 | 286 | -- | Sonia | 12 | Green | $150000 | 287 | -- +-------+-----+-------+---------+ 288 | -- 289 | cap :: c -> Colonnade h a c -> Cornice h (Cap Base) a c 290 | cap h = E.CorniceCap . Vector.singleton . E.OneCornice h . E.CorniceBase 291 | 292 | -- | Add another cap to a cornice. There is no limit to how many times 293 | -- this can be applied: 294 | -- 295 | -- >>> data Day = Weekday | Weekend deriving (Show) 296 | -- >>> :{ 297 | -- let cost :: Int -> Day -> String 298 | -- cost base w = case w of 299 | -- Weekday -> showDollar base 300 | -- Weekend -> showDollar (base + 1) 301 | -- colStandard = foldMap (\c -> headed c (cost 8)) ["Yt","Ad","Sr"] 302 | -- colSpecial = mconcat [headed "Stud" (cost 6), headed "Mltry" (cost 7)] 303 | -- corStatus = mconcat 304 | -- [ cap "Standard" colStandard 305 | -- , cap "Special" colSpecial 306 | -- ] 307 | -- corShowtime = mconcat 308 | -- [ recap "" (cap "" (headed "Day" show)) 309 | -- , foldMap (\c -> recap c corStatus) ["Matinee","Evening"] 310 | -- ] 311 | -- :} 312 | -- 313 | -- >>> putStr (asciiCapped corShowtime [Weekday,Weekend]) 314 | -- +---------+-----------------------------+-----------------------------+ 315 | -- | | Matinee | Evening | 316 | -- +---------+--------------+--------------+--------------+--------------+ 317 | -- | | Standard | Special | Standard | Special | 318 | -- +---------+----+----+----+------+-------+----+----+----+------+-------+ 319 | -- | Day | Yt | Ad | Sr | Stud | Mltry | Yt | Ad | Sr | Stud | Mltry | 320 | -- +---------+----+----+----+------+-------+----+----+----+------+-------+ 321 | -- | Weekday | $8 | $8 | $8 | $6 | $7 | $8 | $8 | $8 | $6 | $7 | 322 | -- | Weekend | $9 | $9 | $9 | $7 | $8 | $9 | $9 | $9 | $7 | $8 | 323 | -- +---------+----+----+----+------+-------+----+----+----+------+-------+ 324 | recap :: c -> Cornice h p a c -> Cornice h (Cap p) a c 325 | recap h cor = E.CorniceCap (Vector.singleton (E.OneCornice h cor)) 326 | 327 | asciiCapped :: Foldable f 328 | => Cornice Headed p a String -- ^ columnar encoding 329 | -> f a -- ^ rows 330 | -> String 331 | asciiCapped cor xs = 332 | let annCor = E.annotateFinely (\x y -> x + y + 3) id 333 | List.length xs cor 334 | sizedCol = E.uncapAnnotated annCor 335 | in E.headersMonoidal 336 | Nothing 337 | [ ( \msz _ -> case msz of 338 | Just sz -> "+" ++ hyphens (sz + 2) 339 | Nothing -> "" 340 | , \s -> s ++ "+\n" 341 | ) 342 | , ( \msz c -> case msz of 343 | Just sz -> "| " ++ rightPad sz ' ' c ++ " " 344 | Nothing -> "" 345 | , \s -> s ++ "|\n" 346 | ) 347 | ] annCor ++ asciiBody sizedCol xs 348 | 349 | 350 | -- | Render a collection of rows as an ascii table. The table\'s columns are 351 | -- specified by the given 'Colonnade'. This implementation is inefficient and 352 | -- does not provide any wrapping behavior. It is provided so that users can 353 | -- try out @colonnade@ in ghci and so that @doctest@ can verify example 354 | -- code in the haddocks. 355 | ascii :: Foldable f 356 | => Colonnade Headed a String -- ^ columnar encoding 357 | -> f a -- ^ rows 358 | -> String 359 | ascii col xs = 360 | let sizedCol = E.sizeColumns List.length xs col 361 | divider = concat 362 | [ E.headerMonoidalFull sizedCol 363 | (\(E.Sized msz _) -> case msz of 364 | Just sz -> "+" ++ hyphens (sz + 2) 365 | Nothing -> "" 366 | ) 367 | , "+\n" 368 | ] 369 | in List.concat 370 | [ divider 371 | , concat 372 | [ E.headerMonoidalFull sizedCol 373 | (\(E.Sized msz (Headed h)) -> case msz of 374 | Just sz -> "| " ++ rightPad sz ' ' h ++ " " 375 | Nothing -> "" 376 | ) 377 | , "|\n" 378 | ] 379 | , asciiBody sizedCol xs 380 | ] 381 | 382 | asciiBody :: Foldable f 383 | => Colonnade (E.Sized (Maybe Int) Headed) a String 384 | -> f a 385 | -> String 386 | asciiBody sizedCol xs = 387 | let divider = concat 388 | [ E.headerMonoidalFull sizedCol 389 | (\(E.Sized msz _) -> case msz of 390 | Just sz -> "+" ++ hyphens (sz + 2) 391 | Nothing -> "" 392 | ) 393 | , "+\n" 394 | ] 395 | rowContents = foldMap 396 | (\x -> concat 397 | [ E.rowMonoidalHeader 398 | sizedCol 399 | (\(E.Sized msz _) c -> case msz of 400 | Nothing -> "" 401 | Just sz -> "| " ++ rightPad sz ' ' c ++ " " 402 | ) 403 | x 404 | , "|\n" 405 | ] 406 | ) xs 407 | in List.concat 408 | [ divider 409 | , rowContents 410 | , divider 411 | ] 412 | 413 | hyphens :: Int -> String 414 | hyphens n = List.replicate n '-' 415 | 416 | rightPad :: Int -> a -> [a] -> [a] 417 | rightPad m a xs = take m $ xs ++ repeat a 418 | 419 | -- data Company = Company String String Int 420 | -- 421 | -- data Company = Company 422 | -- { companyName :: String 423 | -- , companyCountry :: String 424 | -- , companyValue :: Int 425 | -- } deriving (Show) 426 | -- 427 | -- myCompanies :: [Company] 428 | -- myCompanies = 429 | -- [ Company "eCommHub" "United States" 50 430 | -- , Company "Layer 3 Communications" "United States" 10000000 431 | -- , Company "Microsoft" "England" 500000000 432 | -- ] 433 | 434 | 435 | 436 | 437 | 438 | 439 | -------------------------------------------------------------------------------- /colonnade/src/Colonnade/Encode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE KindSignatures #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | 10 | {-# OPTIONS_HADDOCK not-home #-} 11 | {-# OPTIONS_GHC -Wall -fno-warn-unused-imports -fno-warn-unticked-promoted-constructors #-} 12 | 13 | -- | Most users of this library do not need this module. The functions 14 | -- here are used to build functions that apply a 'Colonnade' 15 | -- to a collection of values, building a table from them. Ultimately, 16 | -- a function that applies a @Colonnade Headed MyCell a@ 17 | -- to data will have roughly the following type: 18 | -- 19 | -- > myTableRenderer :: Foldable g => Colonnade Headed MyCell a -> g a -> MyContent 20 | -- 21 | -- In the companion packages @yesod-colonnade@ and 22 | -- @reflex-dom-colonnade@, functions with 23 | -- similar type signatures are readily available. 24 | -- These packages use the functions provided here 25 | -- in the implementations of their rendering functions. 26 | -- It is recommended that users who believe they may need 27 | -- this module look at the source of the companion packages 28 | -- to see an example of how this module\'s functions are used. 29 | -- Other backends are encouraged to use these functions 30 | -- to build monadic or monoidal content from a 'Colonnade'. 31 | -- 32 | -- The functions exported here take a 'Colonnade' and 33 | -- convert it to a fragment of content. The functions whose 34 | -- names start with @row@ take at least a @Colonnade f c a@ and an @a@ 35 | -- value to generate a row of content. The functions whose names 36 | -- start with @header@ need the @Colonnade f c a@ but not 37 | -- an @a@ value since a value is not needed to build a header. 38 | -- 39 | module Colonnade.Encode 40 | ( -- * Colonnade 41 | -- ** Types 42 | Colonnade(..) 43 | , OneColonnade(..) 44 | , Headed(..) 45 | , Headless(..) 46 | , Sized(..) 47 | , ExtractForall(..) 48 | -- ** Typeclasses 49 | , Headedness(..) 50 | -- ** Row 51 | , row 52 | , rowMonadic 53 | , rowMonadic_ 54 | , rowMonadicWith 55 | , rowMonoidal 56 | , rowMonoidalHeader 57 | -- ** Header 58 | , header 59 | , headerMonadic 60 | , headerMonadic_ 61 | , headerMonadicGeneral 62 | , headerMonadicGeneral_ 63 | , headerMonoidalGeneral 64 | , headerMonoidalFull 65 | -- ** Other 66 | , bothMonadic_ 67 | , sizeColumns 68 | -- * Cornice 69 | -- ** Types 70 | , Cornice(..) 71 | , AnnotatedCornice(..) 72 | , OneCornice(..) 73 | , Pillar(..) 74 | , ToEmptyCornice(..) 75 | , Fascia(..) 76 | -- ** Encoding 77 | , annotate 78 | , annotateFinely 79 | , size 80 | , endow 81 | , discard 82 | , headersMonoidal 83 | , uncapAnnotated 84 | ) where 85 | 86 | import Data.Vector (Vector) 87 | import Data.Foldable 88 | import Control.Monad.ST (ST,runST) 89 | import Data.Monoid 90 | import Data.Functor.Contravariant (Contravariant(..)) 91 | import Data.Profunctor (Profunctor(..)) 92 | import Data.Semigroup (Semigroup) 93 | import Data.List.NonEmpty (NonEmpty((:|))) 94 | import Data.Foldable (toList) 95 | import qualified Data.Semigroup as Semigroup 96 | import qualified Data.Vector as Vector 97 | import qualified Data.Vector as V 98 | import qualified Data.Vector.Unboxed.Mutable as MVU 99 | import qualified Data.Vector.Unboxed as VU 100 | import qualified Data.Vector as V 101 | import qualified Data.Vector as Vector 102 | import qualified Data.Vector.Generic as GV 103 | 104 | -- | Consider providing a variant the produces a list 105 | -- instead. It may allow more things to get inlined 106 | -- in to a loop. 107 | row :: (c1 -> c2) -> Colonnade f a c1 -> a -> Vector c2 108 | row g (Colonnade v) a = flip Vector.map v $ 109 | \(OneColonnade _ encode) -> g (encode a) 110 | 111 | bothMonadic_ :: Monad m 112 | => Colonnade Headed a c 113 | -> (c -> c -> m b) 114 | -> a 115 | -> m () 116 | bothMonadic_ (Colonnade v) g a = 117 | forM_ v $ \(OneColonnade (Headed h) encode) -> g h (encode a) 118 | 119 | rowMonadic :: 120 | (Monad m, Monoid b) 121 | => Colonnade f a c 122 | -> (c -> m b) 123 | -> a 124 | -> m b 125 | rowMonadic (Colonnade v) g a = 126 | flip foldlMapM v 127 | $ \e -> g (oneColonnadeEncode e a) 128 | 129 | rowMonadic_ :: 130 | Monad m 131 | => Colonnade f a c 132 | -> (c -> m b) 133 | -> a 134 | -> m () 135 | rowMonadic_ (Colonnade v) g a = 136 | forM_ v $ \e -> g (oneColonnadeEncode e a) 137 | 138 | rowMonoidal :: 139 | Monoid m 140 | => Colonnade h a c 141 | -> (c -> m) 142 | -> a 143 | -> m 144 | rowMonoidal (Colonnade v) g a = 145 | foldMap (\(OneColonnade _ encode) -> g (encode a)) v 146 | 147 | rowMonoidalHeader :: 148 | Monoid m 149 | => Colonnade h a c 150 | -> (h c -> c -> m) 151 | -> a 152 | -> m 153 | rowMonoidalHeader (Colonnade v) g a = 154 | foldMap (\(OneColonnade h encode) -> g h (encode a)) v 155 | 156 | rowUpdateSize :: 157 | (c -> Int) -- ^ Get size from content 158 | -> MutableSizedColonnade s h a c 159 | -> a 160 | -> ST s () 161 | rowUpdateSize toSize (MutableSizedColonnade v mv) a = if MVU.length mv /= V.length v 162 | then error "rowMonoidalSize: vector sizes mismatched" 163 | else V.imapM_ (\ix (OneColonnade _ encode) -> 164 | MVU.modify mv (\oldSize -> max oldSize (toSize (encode a))) ix 165 | ) v 166 | 167 | headerUpdateSize :: Foldable h 168 | => (c -> Int) -- ^ Get size from content 169 | -> MutableSizedColonnade s h a c 170 | -> ST s () 171 | headerUpdateSize toSize (MutableSizedColonnade v mv) = if MVU.length mv /= V.length v 172 | then error "rowMonoidalSize: vector sizes mismatched" 173 | else V.imapM_ (\ix (OneColonnade h _) -> 174 | MVU.modify mv (\oldSize -> max oldSize (foldl' (\sz c -> max sz (toSize c)) 0 h)) ix 175 | ) v 176 | 177 | sizeColumns :: (Foldable f, Foldable h) 178 | => (c -> Int) -- ^ Get size from content 179 | -> f a 180 | -> Colonnade h a c 181 | -> Colonnade (Sized (Maybe Int) h) a c 182 | sizeColumns toSize rows colonnade = runST $ do 183 | mcol <- newMutableSizedColonnade colonnade 184 | headerUpdateSize toSize mcol 185 | mapM_ (rowUpdateSize toSize mcol) rows 186 | freezeMutableSizedColonnade mcol 187 | 188 | newMutableSizedColonnade :: Colonnade h a c -> ST s (MutableSizedColonnade s h a c) 189 | newMutableSizedColonnade (Colonnade v) = do 190 | mv <- MVU.replicate (V.length v) 0 191 | return (MutableSizedColonnade v mv) 192 | 193 | freezeMutableSizedColonnade :: MutableSizedColonnade s h a c -> ST s (Colonnade (Sized (Maybe Int) h) a c) 194 | freezeMutableSizedColonnade (MutableSizedColonnade v mv) = 195 | if MVU.length mv /= V.length v 196 | then error "rowMonoidalSize: vector sizes mismatched" 197 | else do 198 | sizeVec <- VU.freeze mv 199 | return $ Colonnade 200 | $ V.map (\(OneColonnade h enc,sz) -> OneColonnade (Sized (Just sz) h) enc) 201 | $ V.zip v (GV.convert sizeVec) 202 | 203 | rowMonadicWith :: 204 | (Monad m) 205 | => b 206 | -> (b -> b -> b) 207 | -> Colonnade f a c 208 | -> (c -> m b) 209 | -> a 210 | -> m b 211 | rowMonadicWith bempty bappend (Colonnade v) g a = 212 | foldlM (\bl e -> do 213 | br <- g (oneColonnadeEncode e a) 214 | return (bappend bl br) 215 | ) bempty v 216 | 217 | header :: (c1 -> c2) -> Colonnade Headed a c1 -> Vector c2 218 | header g (Colonnade v) = 219 | Vector.map (g . getHeaded . oneColonnadeHead) v 220 | 221 | -- | This function is a helper for abusing 'Foldable' to optionally 222 | -- render a header. Its future is uncertain. 223 | headerMonadicGeneral :: (Monad m, Monoid b, Foldable h) 224 | => Colonnade h a c 225 | -> (c -> m b) 226 | -> m b 227 | headerMonadicGeneral (Colonnade v) g = id 228 | $ fmap (mconcat . Vector.toList) 229 | $ Vector.mapM (foldlMapM g . oneColonnadeHead) v 230 | 231 | headerMonadic :: 232 | (Monad m, Monoid b) 233 | => Colonnade Headed a c 234 | -> (c -> m b) 235 | -> m b 236 | headerMonadic (Colonnade v) g = 237 | fmap (mconcat . Vector.toList) $ Vector.mapM (g . getHeaded . oneColonnadeHead) v 238 | 239 | headerMonadicGeneral_ :: 240 | (Monad m, Headedness h) 241 | => Colonnade h a c 242 | -> (c -> m b) 243 | -> m () 244 | headerMonadicGeneral_ (Colonnade v) g = case headednessExtract of 245 | Nothing -> return () 246 | Just f -> Vector.mapM_ (g . f . oneColonnadeHead) v 247 | 248 | headerMonoidalGeneral :: 249 | (Monoid m, Foldable h) 250 | => Colonnade h a c 251 | -> (c -> m) 252 | -> m 253 | headerMonoidalGeneral (Colonnade v) g = 254 | foldMap (foldMap g . oneColonnadeHead) v 255 | 256 | headerMonoidalFull :: 257 | Monoid m 258 | => Colonnade h a c 259 | -> (h c -> m) 260 | -> m 261 | headerMonoidalFull (Colonnade v) g = foldMap (g . oneColonnadeHead) v 262 | 263 | headerMonadic_ :: 264 | (Monad m) 265 | => Colonnade Headed a c 266 | -> (c -> m b) 267 | -> m () 268 | headerMonadic_ (Colonnade v) g = Vector.mapM_ (g . getHeaded . oneColonnadeHead) v 269 | 270 | foldlMapM :: (Foldable t, Monoid b, Monad m) => (a -> m b) -> t a -> m b 271 | foldlMapM f = foldlM (\b a -> fmap (mappend b) (f a)) mempty 272 | 273 | discard :: Cornice h p a c -> Colonnade h a c 274 | discard = go where 275 | go :: forall h p a c. Cornice h p a c -> Colonnade h a c 276 | go (CorniceBase c) = c 277 | go (CorniceCap children) = Colonnade (getColonnade . go . oneCorniceBody =<< children) 278 | 279 | endow :: forall p a c. (c -> c -> c) -> Cornice Headed p a c -> Colonnade Headed a c 280 | endow f x = case x of 281 | CorniceBase colonnade -> colonnade 282 | CorniceCap v -> Colonnade (V.concatMap (\(OneCornice h b) -> go h b) v) 283 | where 284 | go :: forall p'. c -> Cornice Headed p' a c -> Vector (OneColonnade Headed a c) 285 | go c (CorniceBase (Colonnade v)) = V.map (mapOneColonnadeHeader (f c)) v 286 | go c (CorniceCap v) = V.concatMap (\(OneCornice h b) -> go (f c h) b) v 287 | 288 | uncapAnnotated :: forall sz p a c h. 289 | AnnotatedCornice sz h p a c 290 | -> Colonnade (Sized sz h) a c 291 | uncapAnnotated x = case x of 292 | AnnotatedCorniceBase _ colonnade -> colonnade 293 | AnnotatedCorniceCap _ v -> Colonnade (V.concatMap (\(OneCornice _ b) -> go b) v) 294 | where 295 | go :: forall p'. 296 | AnnotatedCornice sz h p' a c 297 | -> Vector (OneColonnade (Sized sz h) a c) 298 | go (AnnotatedCorniceBase _ (Colonnade v)) = v 299 | go (AnnotatedCorniceCap _ v) = V.concatMap (\(OneCornice _ b) -> go b) v 300 | 301 | annotate :: Cornice Headed p a c -> AnnotatedCornice (Maybe Int) Headed p a c 302 | annotate = go where 303 | go :: forall p a c. Cornice Headed p a c -> AnnotatedCornice (Maybe Int) Headed p a c 304 | go (CorniceBase c) = let len = V.length (getColonnade c) in 305 | AnnotatedCorniceBase 306 | (if len > 0 then (Just len) else Nothing) 307 | (mapHeadedness (Sized (Just 1)) c) 308 | go (CorniceCap children) = 309 | let annChildren = fmap (mapOneCorniceBody go) children 310 | in AnnotatedCorniceCap 311 | ( ( ( V.foldl' (combineJustInt (+)) 312 | ) Nothing . V.map (size . oneCorniceBody) 313 | ) annChildren 314 | ) 315 | annChildren 316 | 317 | combineJustInt :: (Int -> Int -> Int) -> Maybe Int -> Maybe Int -> Maybe Int 318 | combineJustInt f acc el = case acc of 319 | Nothing -> case el of 320 | Nothing -> Nothing 321 | Just i -> Just i 322 | Just i -> case el of 323 | Nothing -> Just i 324 | Just j -> Just (f i j) 325 | 326 | mapJustInt :: (Int -> Int) -> Maybe Int -> Maybe Int 327 | mapJustInt _ Nothing = Nothing 328 | mapJustInt f (Just i) = Just (f i) 329 | 330 | annotateFinely :: Foldable f 331 | => (Int -> Int -> Int) -- ^ fold function 332 | -> (Int -> Int) -- ^ finalize 333 | -> (c -> Int) -- ^ Get size from content 334 | -> f a 335 | -> Cornice Headed p a c 336 | -> AnnotatedCornice (Maybe Int) Headed p a c 337 | annotateFinely g finish toSize xs cornice = runST $ do 338 | m <- newMutableSizedCornice cornice 339 | sizeColonnades toSize xs m 340 | freezeMutableSizedCornice g finish m 341 | 342 | sizeColonnades :: forall f s p a c. 343 | Foldable f 344 | => (c -> Int) -- ^ Get size from content 345 | -> f a 346 | -> MutableSizedCornice s p a c 347 | -> ST s () 348 | sizeColonnades toSize xs cornice = do 349 | goHeader cornice 350 | mapM_ (goRow cornice) xs 351 | where 352 | goRow :: forall p'. MutableSizedCornice s p' a c -> a -> ST s () 353 | goRow (MutableSizedCorniceBase c) a = rowUpdateSize toSize c a 354 | goRow (MutableSizedCorniceCap children) a = mapM_ (flip goRow a . oneCorniceBody) children 355 | goHeader :: forall p'. MutableSizedCornice s p' a c -> ST s () 356 | goHeader (MutableSizedCorniceBase c) = headerUpdateSize toSize c 357 | goHeader (MutableSizedCorniceCap children) = mapM_ (goHeader . oneCorniceBody) children 358 | 359 | freezeMutableSizedCornice :: forall s p a c. 360 | (Int -> Int -> Int) -- ^ fold function 361 | -> (Int -> Int) -- ^ finalize 362 | -> MutableSizedCornice s p a c 363 | -> ST s (AnnotatedCornice (Maybe Int) Headed p a c) 364 | freezeMutableSizedCornice step finish = go 365 | where 366 | go :: forall p' a' c'. 367 | MutableSizedCornice s p' a' c' 368 | -> ST s (AnnotatedCornice (Maybe Int) Headed p' a' c') 369 | go (MutableSizedCorniceBase msc) = do 370 | szCol <- freezeMutableSizedColonnade msc 371 | let sz = 372 | ( mapJustInt finish 373 | . V.foldl' (combineJustInt step) Nothing 374 | . V.map (sizedSize . oneColonnadeHead) 375 | ) (getColonnade szCol) 376 | return (AnnotatedCorniceBase sz szCol) 377 | go (MutableSizedCorniceCap v1) = do 378 | v2 <- V.mapM (traverseOneCorniceBody go) v1 379 | let sz = 380 | ( mapJustInt finish 381 | . V.foldl' (combineJustInt step) Nothing 382 | . V.map (size . oneCorniceBody) 383 | ) v2 384 | return $ AnnotatedCorniceCap sz v2 385 | 386 | newMutableSizedCornice :: forall s p a c. 387 | Cornice Headed p a c 388 | -> ST s (MutableSizedCornice s p a c) 389 | newMutableSizedCornice = go where 390 | go :: forall p'. Cornice Headed p' a c -> ST s (MutableSizedCornice s p' a c) 391 | go (CorniceBase c) = fmap MutableSizedCorniceBase (newMutableSizedColonnade c) 392 | go (CorniceCap v) = fmap MutableSizedCorniceCap (V.mapM (traverseOneCorniceBody go) v) 393 | 394 | traverseOneCorniceBody :: Monad m => (k p a c -> m (j p a c)) -> OneCornice k p a c -> m (OneCornice j p a c) 395 | traverseOneCorniceBody f (OneCornice h b) = fmap (OneCornice h) (f b) 396 | 397 | mapHeadedness :: (forall x. h x -> h' x) -> Colonnade h a c -> Colonnade h' a c 398 | mapHeadedness f (Colonnade v) = 399 | Colonnade (V.map (\(OneColonnade h c) -> OneColonnade (f h) c) v) 400 | 401 | 402 | -- | This is an O(1) operation, sort of 403 | size :: AnnotatedCornice sz h p a c -> sz 404 | size x = case x of 405 | AnnotatedCorniceBase m _ -> m 406 | AnnotatedCorniceCap sz _ -> sz 407 | 408 | mapOneCorniceBody :: (forall p' a' c'. k p' a' c' -> j p' a' c') -> OneCornice k p a c -> OneCornice j p a c 409 | mapOneCorniceBody f (OneCornice h b) = OneCornice h (f b) 410 | 411 | mapOneColonnadeHeader :: Functor h => (c -> c) -> OneColonnade h a c -> OneColonnade h a c 412 | mapOneColonnadeHeader f (OneColonnade h b) = OneColonnade (fmap f h) b 413 | 414 | headersMonoidal :: forall sz r m c p a h. 415 | (Monoid m, Headedness h) 416 | => Maybe (Fascia p r, r -> m -> m) -- ^ Apply the Fascia header row content 417 | -> [(sz -> c -> m, m -> m)] -- ^ Build content from cell content and size 418 | -> AnnotatedCornice sz h p a c 419 | -> m 420 | headersMonoidal wrapRow fromContentList = go wrapRow 421 | where 422 | go :: forall p'. Maybe (Fascia p' r, r -> m -> m) -> AnnotatedCornice sz h p' a c -> m 423 | go ef (AnnotatedCorniceBase _ (Colonnade v)) = 424 | let g :: m -> m 425 | g m = case ef of 426 | Nothing -> m 427 | Just (FasciaBase r, f) -> f r m 428 | in case headednessExtract of 429 | Just unhead -> g $ foldMap (\(fromContent,wrap) -> wrap 430 | (foldMap (\(OneColonnade (Sized sz h) _) -> 431 | (fromContent sz (unhead h))) v)) fromContentList 432 | Nothing -> mempty 433 | go ef (AnnotatedCorniceCap _ v) = 434 | let g :: m -> m 435 | g m = case ef of 436 | Nothing -> m 437 | Just (FasciaCap r _, f) -> f r m 438 | in g (foldMap (\(fromContent,wrap) -> wrap (foldMap (\(OneCornice h b) -> 439 | (fromContent (size b) h)) v)) fromContentList) 440 | <> case ef of 441 | Nothing -> case flattenAnnotated v of 442 | Nothing -> mempty 443 | Just annCoreNext -> go Nothing annCoreNext 444 | Just (FasciaCap _ fn, f) -> case flattenAnnotated v of 445 | Nothing -> mempty 446 | Just annCoreNext -> go (Just (fn,f)) annCoreNext 447 | 448 | flattenAnnotated :: 449 | Vector (OneCornice (AnnotatedCornice sz h) p a c) 450 | -> Maybe (AnnotatedCornice sz h p a c) 451 | flattenAnnotated v = case v V.!? 0 of 452 | Nothing -> Nothing 453 | Just (OneCornice _ x) -> Just $ case x of 454 | AnnotatedCorniceBase m _ -> flattenAnnotatedBase m v 455 | AnnotatedCorniceCap m _ -> flattenAnnotatedCap m v 456 | 457 | flattenAnnotatedBase :: 458 | sz 459 | -> Vector (OneCornice (AnnotatedCornice sz h) Base a c) 460 | -> AnnotatedCornice sz h Base a c 461 | flattenAnnotatedBase msz = AnnotatedCorniceBase msz 462 | . Colonnade 463 | . V.concatMap 464 | (\(OneCornice _ (AnnotatedCorniceBase _ (Colonnade v))) -> v) 465 | 466 | flattenAnnotatedCap :: 467 | sz 468 | -> Vector (OneCornice (AnnotatedCornice sz h) (Cap p) a c) 469 | -> AnnotatedCornice sz h (Cap p) a c 470 | flattenAnnotatedCap m = AnnotatedCorniceCap m . V.concatMap getTheVector 471 | 472 | getTheVector :: 473 | OneCornice (AnnotatedCornice sz h) (Cap p) a c 474 | -> Vector (OneCornice (AnnotatedCornice sz h) p a c) 475 | getTheVector (OneCornice _ (AnnotatedCorniceCap _ v)) = v 476 | 477 | data MutableSizedCornice s (p :: Pillar) a c where 478 | MutableSizedCorniceBase :: 479 | {-# UNPACK #-} !(MutableSizedColonnade s Headed a c) 480 | -> MutableSizedCornice s Base a c 481 | MutableSizedCorniceCap :: 482 | {-# UNPACK #-} !(Vector (OneCornice (MutableSizedCornice s) p a c)) 483 | -> MutableSizedCornice s (Cap p) a c 484 | 485 | data MutableSizedColonnade s h a c = MutableSizedColonnade 486 | { _mutableSizedColonnadeColumns :: {-# UNPACK #-} !(Vector (OneColonnade h a c)) 487 | , _mutableSizedColonnadeSizes :: {-# UNPACK #-} !(MVU.STVector s Int) 488 | } 489 | 490 | -- | As the first argument to the 'Colonnade' type 491 | -- constructor, this indictates that the columnar encoding has 492 | -- a header. This type is isomorphic to 'Identity' but is 493 | -- given a new name to clarify its intent: 494 | -- 495 | -- > example :: Colonnade Headed Foo Text 496 | -- 497 | -- The term @example@ represents a columnar encoding of @Foo@ 498 | -- in which the columns have headings. 499 | newtype Headed a = Headed { getHeaded :: a } 500 | deriving (Eq,Ord,Functor,Show,Read,Foldable) 501 | 502 | instance Applicative Headed where 503 | pure = Headed 504 | Headed f <*> Headed a = Headed (f a) 505 | 506 | -- | As the first argument to the 'Colonnade' type 507 | -- constructor, this indictates that the columnar encoding does not have 508 | -- a header. This type is isomorphic to 'Proxy' but is 509 | -- given a new name to clarify its intent: 510 | -- 511 | -- > example :: Colonnade Headless Foo Text 512 | -- 513 | -- The term @example@ represents a columnar encoding of @Foo@ 514 | -- in which the columns do not have headings. 515 | data Headless a = Headless 516 | deriving (Eq,Ord,Functor,Show,Read,Foldable) 517 | 518 | instance Applicative Headless where 519 | pure _ = Headless 520 | Headless <*> Headless = Headless 521 | 522 | data Sized sz f a = Sized 523 | { sizedSize :: !sz 524 | , sizedContent :: !(f a) 525 | } deriving (Functor, Foldable) 526 | 527 | instance Contravariant Headless where 528 | contramap _ Headless = Headless 529 | 530 | -- | Encodes a header and a cell. 531 | data OneColonnade h a c = OneColonnade 532 | { oneColonnadeHead :: !(h c) 533 | , oneColonnadeEncode :: !(a -> c) 534 | } deriving (Functor) 535 | 536 | instance Functor h => Profunctor (OneColonnade h) where 537 | rmap = fmap 538 | lmap f (OneColonnade h e) = OneColonnade h (e . f) 539 | 540 | -- | An columnar encoding of @a@. The type variable @h@ determines what 541 | -- is present in each column in the header row. It is typically instantiated 542 | -- to 'Headed' and occasionally to 'Headless'. There is nothing that 543 | -- restricts it to these two types, although they satisfy the majority 544 | -- of use cases. The type variable @c@ is the content type. This can 545 | -- be @Text@, @String@, or @ByteString@. In the companion libraries 546 | -- @reflex-dom-colonnade@ and @yesod-colonnade@, additional types 547 | -- that represent HTML with element attributes are provided that serve 548 | -- as the content type. Presented more visually: 549 | -- 550 | -- > +---- Value consumed to build a row 551 | -- > | 552 | -- > v 553 | -- > Colonnade h a c 554 | -- > ^ ^ 555 | -- > | | 556 | -- > | +-- Content (Text, ByteString, Html, etc.) 557 | -- > | 558 | -- > +------ Headedness (Headed or Headless) 559 | -- 560 | -- Internally, a 'Colonnade' is represented as a 'Vector' of individual 561 | -- column encodings. It is possible to use any collection type with 562 | -- 'Alternative' and 'Foldable' instances. However, 'Vector' was chosen to 563 | -- optimize the data structure for the use case of building the structure 564 | -- once and then folding over it many times. It is recommended that 565 | -- 'Colonnade's are defined at the top-level so that GHC avoids reconstructing 566 | -- them every time they are used. 567 | newtype Colonnade h a c = Colonnade 568 | { getColonnade :: Vector (OneColonnade h a c) 569 | } deriving (Monoid,Functor) 570 | 571 | instance Functor h => Profunctor (Colonnade h) where 572 | rmap = fmap 573 | lmap f (Colonnade v) = Colonnade (Vector.map (lmap f) v) 574 | 575 | instance Semigroup (Colonnade h a c) where 576 | Colonnade a <> Colonnade b = Colonnade (a Vector.++ b) 577 | sconcat xs = Colonnade (vectorConcatNE (fmap getColonnade xs)) 578 | 579 | -- | Isomorphic to the natural numbers. Only the promoted version of 580 | -- this type is used. 581 | data Pillar = Cap !Pillar | Base 582 | 583 | class ToEmptyCornice (p :: Pillar) where 584 | toEmptyCornice :: Cornice h p a c 585 | 586 | instance ToEmptyCornice Base where 587 | toEmptyCornice = CorniceBase mempty 588 | 589 | instance ToEmptyCornice (Cap p) where 590 | toEmptyCornice = CorniceCap Vector.empty 591 | 592 | data Fascia (p :: Pillar) r where 593 | FasciaBase :: !r -> Fascia Base r 594 | FasciaCap :: !r -> Fascia p r -> Fascia (Cap p) r 595 | 596 | data OneCornice k (p :: Pillar) a c = OneCornice 597 | { oneCorniceHead :: !c 598 | , oneCorniceBody :: !(k p a c) 599 | } deriving (Functor) 600 | 601 | data Cornice h (p :: Pillar) a c where 602 | CorniceBase :: !(Colonnade h a c) -> Cornice h Base a c 603 | CorniceCap :: {-# UNPACK #-} !(Vector (OneCornice (Cornice h) p a c)) -> Cornice h (Cap p) a c 604 | 605 | instance Functor h => Functor (Cornice h p a) where 606 | fmap f x = case x of 607 | CorniceBase c -> CorniceBase (fmap f c) 608 | CorniceCap c -> CorniceCap (mapVectorCornice f c) 609 | 610 | instance Functor h => Profunctor (Cornice h p) where 611 | rmap = fmap 612 | lmap f x = case x of 613 | CorniceBase c -> CorniceBase (lmap f c) 614 | CorniceCap c -> CorniceCap (contramapVectorCornice f c) 615 | 616 | instance Semigroup (Cornice h p a c) where 617 | CorniceBase a <> CorniceBase b = CorniceBase (mappend a b) 618 | CorniceCap a <> CorniceCap b = CorniceCap (a Vector.++ b) 619 | sconcat xs@(x :| _) = case x of 620 | CorniceBase _ -> CorniceBase (Colonnade (vectorConcatNE (fmap (getColonnade . getCorniceBase) xs))) 621 | CorniceCap _ -> CorniceCap (vectorConcatNE (fmap getCorniceCap xs)) 622 | 623 | instance ToEmptyCornice p => Monoid (Cornice h p a c) where 624 | mempty = toEmptyCornice 625 | mappend = (Semigroup.<>) 626 | mconcat xs1 = case xs1 of 627 | [] -> toEmptyCornice 628 | x : xs2 -> Semigroup.sconcat (x :| xs2) 629 | 630 | mapVectorCornice :: Functor h => (c -> d) -> Vector (OneCornice (Cornice h) p a c) -> Vector (OneCornice (Cornice h) p a d) 631 | mapVectorCornice f = V.map (fmap f) 632 | 633 | contramapVectorCornice :: Functor h => (b -> a) -> Vector (OneCornice (Cornice h) p a c) -> Vector (OneCornice (Cornice h) p b c) 634 | contramapVectorCornice f = V.map (lmapOneCornice f) 635 | 636 | lmapOneCornice :: Functor h => (b -> a) -> OneCornice (Cornice h) p a c -> OneCornice (Cornice h) p b c 637 | lmapOneCornice f (OneCornice theHead theBody) = OneCornice theHead (lmap f theBody) 638 | 639 | getCorniceBase :: Cornice h Base a c -> Colonnade h a c 640 | getCorniceBase (CorniceBase c) = c 641 | 642 | getCorniceCap :: Cornice h (Cap p) a c -> Vector (OneCornice (Cornice h) p a c) 643 | getCorniceCap (CorniceCap c) = c 644 | 645 | data AnnotatedCornice sz h (p :: Pillar) a c where 646 | AnnotatedCorniceBase :: 647 | !sz 648 | -> !(Colonnade (Sized sz h) a c) 649 | -> AnnotatedCornice sz h Base a c 650 | AnnotatedCorniceCap :: 651 | !sz 652 | -> {-# UNPACK #-} !(Vector (OneCornice (AnnotatedCornice sz h) p a c)) 653 | -> AnnotatedCornice sz h (Cap p) a c 654 | 655 | -- data MaybeInt = JustInt {-# UNPACK #-} !Int | NothingInt 656 | 657 | -- | This is provided with @vector-0.12@, but we include a copy here 658 | -- for compatibility. 659 | vectorConcatNE :: NonEmpty (Vector a) -> Vector a 660 | vectorConcatNE = Vector.concat . toList 661 | 662 | -- | This class communicates that a container holds either zero 663 | -- elements or one element. Furthermore, all inhabitants of 664 | -- the type must hold the same number of elements. Both 665 | -- 'Headed' and 'Headless' have instances. The following 666 | -- law accompanies any instances: 667 | -- 668 | -- > maybe x (\f -> f (headednessPure x)) headednessContents == x 669 | -- > todo: come up with another law that relates to Traversable 670 | -- 671 | -- Consequently, there is no instance for 'Maybe', which cannot 672 | -- satisfy the laws since it has inhabitants which hold different 673 | -- numbers of elements. 'Nothing' holds 0 elements and 'Just' holds 674 | -- 1 element. 675 | class Headedness h where 676 | headednessPure :: a -> h a 677 | headednessExtract :: Maybe (h a -> a) 678 | headednessExtractForall :: Maybe (ExtractForall h) 679 | 680 | instance Headedness Headed where 681 | headednessPure = Headed 682 | headednessExtract = Just getHeaded 683 | headednessExtractForall = Just (ExtractForall getHeaded) 684 | 685 | instance Headedness Headless where 686 | headednessPure _ = Headless 687 | headednessExtract = Nothing 688 | headednessExtractForall = Nothing 689 | 690 | newtype ExtractForall h = ExtractForall { runExtractForall :: forall a. h a -> a } 691 | 692 | -------------------------------------------------------------------------------- /geolite-csv/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Andrew Martin (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Andrew Martin nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /geolite-csv/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /geolite-csv/data/small/GeoLite2-City-Blocks-IPv4.csv: -------------------------------------------------------------------------------- 1 | network,geoname_id,registered_country_geoname_id,represented_country_geoname_id,is_anonymous_proxy,is_satellite_provider,postal_code,latitude,longitude,accuracy_radius 2 | 24.165.56.0/22,5848280,6252001,,0,0,96746,22.0837,-159.3553,10 3 | 78.146.173.128/25,2655583,2635167,,0,0,DL14,54.6500,-1.6667,20 4 | 121.211.108.0/23,2160386,2077456,,0,0,2040,-33.8833,151.1500,5 5 | 69.74.43.16/30,6252001,6252001,,0,0,,37.7510,-97.8220,1000 6 | 77.128.35.136/30,3034803,3017382,,0,0,57450,49.0667,6.8333,20 7 | 90.54.234.0/24,2977062,3017382,,0,0,49320,47.3944,-0.4357,50 8 | 77.193.41.175/32,3018587,3017382,,0,0,78810,48.8700,1.9740,1 9 | 58.188.32.0/24,1861060,1861060,,0,0,,35.6900,139.6900,500 10 | 87.81.232.0/24,2635167,2635167,,0,0,,51.4964,-0.1224,200 11 | 88.191.56.0/22,2988507,3017382,,0,0,75001,48.8667,2.3333,500 12 | -------------------------------------------------------------------------------- /geolite-csv/data/small/GeoLite2-City-Locations-en.csv: -------------------------------------------------------------------------------- 1 | geoname_id,locale_code,continent_code,continent_name,country_iso_code,country_name,subdivision_1_iso_code,subdivision_1_name,subdivision_2_iso_code,subdivision_2_name,city_name,metro_code,time_zone 2 | 2653810,en,EU,Europe,GB,"United Kingdom",SCT,Scotland,GLG,"Glasgow City",Cardonald,,Europe/London 3 | 2832529,en,EU,Europe,DE,Germany,RP,Rheinland-Pfalz,,,Siefersheim,,Europe/Berlin 4 | 2885499,en,EU,Europe,DE,Germany,MV,Mecklenburg-Vorpommern,,,Koerchow,,Europe/Berlin 5 | 550870,en,EU,Europe,RU,Russia,NIZ,"Nizhegorodskaya Oblast'",,,Khabarskoye,,Europe/Moscow 6 | 766583,en,EU,Europe,PL,Poland,LU,"Lublin Voivodeship",,,Leczna,,Europe/Warsaw 7 | 2608246,en,EU,Europe,AT,Austria,1,Burgenland,,,"Neuhaus am Klausenbach",,Europe/Vienna 8 | 5121765,en,NA,"North America",US,"United States",NY,"New York",,,Ilion,526,America/New_York 9 | 2935825,en,EU,Europe,DE,Germany,NW,"North Rhine-Westphalia",,,Dormagen,,Europe/Berlin 10 | 3165189,en,EU,Europe,IT,Italy,36,"Friuli Venezia Giulia",UD,"Provincia di Udine",Tricesimo,,Europe/Rome 11 | 4564070,en,NA,"North America",PR,"Puerto Rico",,,,,Culebra,,America/Puerto_Rico 12 | 2993759,en,EU,Europe,FR,France,U,"Provence-Alpes-Côte d'Azur",13,Bouches-du-Rhône,Miramas-le-Vieux,,Europe/Paris 13 | 5861117,en,NA,"North America",US,"United States",AK,Alaska,,,"Dutch Harbor",743,America/Adak 14 | 4375229,en,NA,"North America",US,"United States",MO,Missouri,,,Ashland,604,America/Chicago 15 | 2946980,en,EU,Europe,DE,Germany,SN,Saxony,,,Boehlen,,Europe/Berlin 16 | 3156470,en,EU,Europe,NO,Norway,02,Akershus,,,Frogner,,Europe/Oslo 17 | 3166193,en,EU,Europe,IT,Italy,36,"Friuli Venezia Giulia",GO,"Provincia di Gorizia",Staranzano,,Europe/Rome 18 | 4913742,en,NA,"North America",US,"United States",IL,Illinois,,,Tiskilwa,675,America/Chicago 19 | 4853511,en,NA,"North America",US,"United States",IA,Iowa,,,Dayton,679,America/Chicago 20 | 480876,en,EU,Europe,RU,Russia,ROS,Rostov,,,Tsimlyansk,,Europe/Moscow 21 | 3000119,en,EU,Europe,FR,France,89,Yonne,,,"Les Ormes",,Europe/Paris 22 | -------------------------------------------------------------------------------- /geolite-csv/data/small/GeoLite2-City-Locations-ja.csv: -------------------------------------------------------------------------------- 1 | geoname_id,locale_code,continent_code,continent_name,country_iso_code,country_name,subdivision_1_iso_code,subdivision_1_name,subdivision_2_iso_code,subdivision_2_name,city_name,metro_code,time_zone 2 | 1260633,ja,AS,"アジア",IN,"インド",AP,"アーンドラ・プラデーシュ州",,,,,Asia/Kolkata 3 | 4765167,ja,NA,"北アメリカ",US,"アメリカ合衆国",VA,"バージニア州",,,,573,America/New_York 4 | 2703330,ja,EU,"ヨーロッパ",SE,"スウェーデン王国",Z,,,,,,Europe/Stockholm 5 | 535886,ja,EU,"ヨーロッパ",RU,"ロシア",STA,,,,,,Europe/Moscow 6 | 2989001,ja,EU,"ヨーロッパ",FR,"フランス共和国",F,,28,,,,Europe/Paris 7 | 3183178,ja,EU,"ヨーロッパ",IT,"イタリア共和国",75,"プッリャ州",BA,,"アルタムーラ",,Europe/Rome 8 | 3012956,ja,EU,"ヨーロッパ",FR,"フランス共和国",67,,,,,,Europe/Paris 9 | 4189157,ja,NA,"北アメリカ",US,"アメリカ合衆国",GA,"ジョージア州",,,,524,America/New_York 10 | 2758965,ja,EU,"ヨーロッパ",NL,"オランダ王国",ZE,,,,,,Europe/Amsterdam 11 | 3570412,ja,NA,"北アメリカ",MQ,"マルティニーク島",,,,,,,America/Martinique 12 | 3095604,ja,EU,"ヨーロッパ",PL,"ポーランド共和国",MZ,"マゾフシェ県",,,,,Europe/Warsaw 13 | 3070865,ja,EU,"ヨーロッパ",CZ,"チェコ共和国",ST,"中央ボヘミア州",,,,,Europe/Prague 14 | 2636062,ja,EU,"ヨーロッパ",GB,"イギリス",ENG,"イングランド",SRY,,,,Europe/London 15 | 3019338,ja,EU,"ヨーロッパ",FR,"フランス共和国",57,,,,,,Europe/Paris 16 | 2865603,ja,EU,"ヨーロッパ",DE,"ドイツ連邦共和国",BY,"バイエルン州",,,"ノイエンマルクト",,Europe/Berlin 17 | 2930628,ja,EU,"ヨーロッパ",DE,"ドイツ連邦共和国",HE,,,,,,Europe/Berlin 18 | 2976283,ja,EU,"ヨーロッパ",FR,"フランス共和国",01,,,,,,Europe/Paris 19 | 4062424,ja,NA,"北アメリカ",US,"アメリカ合衆国",AL,"アラバマ州",,,,575,America/Chicago 20 | 4461574,ja,NA,"北アメリカ",US,"アメリカ合衆国",NC,"ノースカロライナ州",,,"コンコード",517,America/New_York 21 | 1279945,ja,AS,"アジア",CN,"中国",62,,,,"酒泉市",,Asia/Shanghai 22 | -------------------------------------------------------------------------------- /geolite-csv/geolite-csv.cabal: -------------------------------------------------------------------------------- 1 | name: geolite-csv 2 | version: 0.2 3 | synopsis: Geolite CSV Parser 4 | description: Please see README.md 5 | homepage: https://github.com/andrewthad/colonnade 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Andrew Martin 9 | maintainer: andrew.thaddeus@gmail.com 10 | copyright: 2016 Andrew Martin 11 | category: web 12 | build-type: Simple 13 | -- extra-source-files: 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: 19 | Geolite.Types 20 | Geolite.Csv 21 | build-depends: 22 | base >= 4.7 && < 5 23 | , colonnade 24 | , siphon 25 | , ip >= 0.8.4 26 | , text 27 | , pipes 28 | default-language: Haskell2010 29 | 30 | test-suite geolite-csv-test 31 | type: exitcode-stdio-1.0 32 | hs-source-dirs: test 33 | main-is: Spec.hs 34 | build-depends: 35 | base 36 | , geolite-csv 37 | , siphon 38 | , colonnade 39 | , test-framework 40 | , text 41 | , pipes 42 | , HUnit 43 | , test-framework-hunit 44 | , pipes-bytestring 45 | , pipes-text 46 | , directory 47 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 48 | default-language: Haskell2010 49 | 50 | source-repository head 51 | type: git 52 | location: https://github.com/andrewthad/colonnade 53 | -------------------------------------------------------------------------------- /geolite-csv/hackage-docs.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | 4 | if [ "$#" -ne 1 ]; then 5 | echo "Usage: scripts/hackage-docs.sh HACKAGE_USER" 6 | exit 1 7 | fi 8 | 9 | user=$1 10 | 11 | cabal_file=$(find . -maxdepth 1 -name "*.cabal" -print -quit) 12 | if [ ! -f "$cabal_file" ]; then 13 | echo "Run this script in the top-level package directory" 14 | exit 1 15 | fi 16 | 17 | pkg=$(awk -F ":[[:space:]]*" 'tolower($1)=="name" { print $2 }' < "$cabal_file") 18 | ver=$(awk -F ":[[:space:]]*" 'tolower($1)=="version" { print $2 }' < "$cabal_file") 19 | 20 | if [ -z "$pkg" ]; then 21 | echo "Unable to determine package name" 22 | exit 1 23 | fi 24 | 25 | if [ -z "$ver" ]; then 26 | echo "Unable to determine package version" 27 | exit 1 28 | fi 29 | 30 | echo "Detected package: $pkg-$ver" 31 | 32 | dir=$(mktemp -d build-docs.XXXXXX) 33 | trap 'rm -r "$dir"' EXIT 34 | 35 | # cabal haddock --hoogle --hyperlink-source --html-location='/package/$pkg-$version/docs' --contents-location='/package/$pkg-$version' 36 | stack haddock 37 | 38 | cp -R .stack-work/dist/x86_64-linux/Cabal-1.22.5.0/doc/html/$pkg/ $dir/$pkg-$ver-docs 39 | # /home/andrew/.stack/snapshots/x86_64-linux/lts-5.17/7.10.3/doc/index.html 40 | 41 | tar cvz -C $dir --format=ustar -f $dir/$pkg-$ver-docs.tar.gz $pkg-$ver-docs 42 | 43 | curl -X PUT \ 44 | -H 'Content-Type: application/x-tar' \ 45 | -H 'Content-Encoding: gzip' \ 46 | -u "$user" \ 47 | --data-binary "@$dir/$pkg-$ver-docs.tar.gz" \ 48 | "https://hackage.haskell.org/package/$pkg-$ver/docs" 49 | -------------------------------------------------------------------------------- /geolite-csv/scripts/load-full-databases: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | 5 | current_dir="${PWD##*/}" 6 | 7 | echo "Current directory is: $current_dir" 8 | 9 | if [ "$current_dir" = "colonnade" ] 10 | then 11 | cd ./geolite-csv 12 | fi 13 | 14 | new_current_dir="${PWD##*/}" 15 | if [ "$new_current_dir" != "geolite-csv" ] 16 | then 17 | echo "Not currently in the geolite project directory. Exiting." 18 | exit 1 19 | fi 20 | 21 | mkdir -p ./data/large 22 | cd ./data/large 23 | 24 | rm -f *.zip 25 | rm -rf GeoLite2-* 26 | 27 | curl 'http://geolite.maxmind.com/download/geoip/database/GeoLite2-City-CSV.zip' > archive.zip 28 | unzip archive.zip -d ./ 29 | 30 | cd GeoLite2-City-CSV* 31 | mv *.csv ../ 32 | cd ../ 33 | rm -rf GeoLite2-City-CSV* 34 | rm archive.zip 35 | 36 | -------------------------------------------------------------------------------- /geolite-csv/src/Geolite/Csv.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Geolite.Csv where 4 | 5 | import Data.Text (Text) 6 | import Pipes (Pipe) 7 | import Colonnade.Types 8 | import Geolite.Types 9 | 10 | import qualified Data.Text as Text 11 | import qualified Net.IPv4.Range.Text as IPv4RangeText 12 | import qualified Data.Text.Read as TextRead 13 | import qualified Siphon.Decoding as SD 14 | import qualified Siphon.Content as SC 15 | import qualified Colonnade.Decoding.Text as CDT 16 | import qualified Colonnade.Decoding as CD 17 | 18 | cities :: Monad m => Pipe Text City m (DecodingRowError Headed Text) 19 | cities = SD.headedPipe SC.text decodingCity 20 | 21 | blocks :: Monad m => Pipe Text Block m (DecodingRowError Headed Text) 22 | blocks = SD.headedPipe SC.text decodingBlock 23 | 24 | decodingCity :: Decoding Headed Text City 25 | decodingCity = City 26 | <$> fmap GeonameId (CD.headed "geoname_id" CDT.int) 27 | <*> CD.headed "locale_code" CDT.text 28 | <*> CD.headed "continent_code" CDT.text 29 | <*> CD.headed "continent_name" CDT.text 30 | <*> CD.headed "country_iso_code" CDT.text 31 | <*> CD.headed "country_name" CDT.text 32 | <*> CD.headed "subdivision_1_iso_code" CDT.text 33 | <*> CD.headed "subdivision_1_name" CDT.text 34 | <*> CD.headed "subdivision_2_iso_code" CDT.text 35 | <*> CD.headed "subdivision_2_name" CDT.text 36 | <*> CD.headed "city_name" CDT.text 37 | <*> CD.headed "metro_code" (CDT.optional CDT.int) 38 | <*> CD.headed "time_zone" CDT.text 39 | 40 | decodingBlock :: Decoding Headed Text Block 41 | decodingBlock = Block 42 | <$> CD.headed "network" IPv4RangeText.decodeEither 43 | <*> CD.headed "geoname_id" 44 | (CDT.optional $ CDT.map GeonameId CDT.int) 45 | <*> CD.headed "registered_country_geoname_id" 46 | (CDT.optional $ CDT.map GeonameId CDT.int) 47 | <*> CD.headed "represented_country_geoname_id" 48 | (CDT.optional $ CDT.map GeonameId CDT.int) 49 | <*> CD.headed "is_anonymous_proxy" (CDT.trueFalse "1" "0") 50 | <*> CD.headed "is_satellite_provider" (CDT.trueFalse "1" "0") 51 | <*> CD.headed "postal_code" CDT.text 52 | <*> CD.headed "latitude" 53 | (CDT.optional $ CDT.fromReader TextRead.rational) 54 | <*> CD.headed "longitude" 55 | (CDT.optional $ CDT.fromReader TextRead.rational) 56 | <*> CD.headed "accuracy_radius" 57 | (CDT.optional CDT.int) 58 | 59 | 60 | -------------------------------------------------------------------------------- /geolite-csv/src/Geolite/Types.hs: -------------------------------------------------------------------------------- 1 | module Geolite.Types where 2 | 3 | import Net.Types (IPv4Range) 4 | import Data.Text (Text) 5 | import Data.Fixed 6 | 7 | data E4 8 | 9 | instance HasResolution E4 where 10 | resolution _ = 4 11 | 12 | newtype GeonameId = GeonameId { getGeonameId :: Int } 13 | deriving (Show,Read,Eq,Ord) 14 | 15 | data City = City 16 | { cityGeonameId :: GeonameId 17 | , cityLocaleCode :: Text 18 | , cityContinentCode :: Text 19 | , cityContinentName :: Text 20 | , cityCountryIsoCode :: Text 21 | , cityCountryName :: Text 22 | , citySubdivision1IsoCode :: Text 23 | , citySubdivision1Name :: Text 24 | , citySubdivision2IsoCode :: Text 25 | , citySubdivision2Name :: Text 26 | , cityName :: Text 27 | , cityMetroCode :: Maybe Int 28 | , cityTimeZone :: Text 29 | } deriving (Show,Read,Eq,Ord) 30 | 31 | data Block = Block 32 | { blockNetwork :: IPv4Range 33 | , blockGeonameId :: Maybe GeonameId 34 | , blockRegisteredCountryGeonameId :: Maybe GeonameId 35 | , blockRepresentedCountryGeonameId :: Maybe GeonameId 36 | , blockIsAnonymousProxy :: Bool 37 | , blockIsSatelliteProvider :: Bool 38 | , blockPostalCode :: Text 39 | , blockLatitude :: Maybe (Fixed E4) 40 | , blockLongitude :: Maybe (Fixed E4) 41 | , blockAccuracyRadius :: Maybe Int 42 | } deriving (Show,Read,Eq,Ord) 43 | 44 | -------------------------------------------------------------------------------- /geolite-csv/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main (main) where 4 | 5 | import Test.HUnit (Assertion,(@?=),assertBool,assertFailure) 6 | import Test.Framework (defaultMainWithOpts, interpretArgsOrExit, 7 | testGroup, Test) 8 | import Test.Framework.Providers.HUnit (testCase) 9 | import Test.Framework.Runners.TestPattern (parseTestPattern) 10 | import Test.Framework.Runners.Options (RunnerOptions'(..)) 11 | import Geolite.Csv (cities,blocks) 12 | import Data.Text (Text) 13 | import Colonnade.Types 14 | import Siphon.Types 15 | import Data.Functor.Identity 16 | import Control.Monad (unless) 17 | import System.Environment (getArgs) 18 | import System.Directory (doesDirectoryExist) 19 | import System.IO (withFile,IOMode(ReadMode)) 20 | import qualified Data.Text as Text 21 | import qualified Pipes.Prelude as Pipes 22 | import qualified Pipes.ByteString as PB 23 | import qualified Pipes.Text.Encoding as PT 24 | import qualified Siphon.Decoding as SD 25 | import qualified Colonnade.Decoding as Decoding 26 | import Pipes 27 | 28 | ------------------------------------------------ 29 | -- The default behavior of this test suite is to 30 | -- test the CSV decoders against small samples of 31 | -- the GeoLite2 databases. These small samples are 32 | -- included as part of this repository. If you give 33 | -- this test suite an argument named "large", it 34 | -- will run against the full CSVs, which are around 35 | -- 350MB. These are not included 36 | -- as part of the repository, so they need to be 37 | -- downloaded. The script found in 38 | -- scripts/load-full-databases will download the full 39 | -- archive, decompress it, and move the files to 40 | -- the appropriate directory for this test suite 41 | -- to run on them. 42 | ----------------------------------------------- 43 | 44 | main :: IO () 45 | main = do 46 | xs <- getArgs 47 | ropts' <- interpretArgsOrExit xs 48 | let ropts = ropts' 49 | { ropt_test_patterns = case ropt_test_patterns ropts' of 50 | Nothing -> Just [parseTestPattern "small"] 51 | Just xs -> Just xs 52 | } 53 | defaultMainWithOpts tests ropts 54 | 55 | tests :: [Test] 56 | tests = flip concatMap ["small","large"] $ \size -> 57 | [ testGroup size 58 | [ testCase "Network Blocks" $ streamFileWith 59 | ("data/" ++ size ++ "/GeoLite2-City-Blocks-IPv4.csv") 60 | blocks 61 | , testCase "English City Locations" $ streamFileWith 62 | ("data/" ++ size ++ "/GeoLite2-City-Locations-en.csv") 63 | cities 64 | , testCase "Japanese City Locations" $ streamFileWith 65 | ("data/" ++ size ++ "/GeoLite2-City-Locations-ja.csv") 66 | cities 67 | ] 68 | ] 69 | 70 | streamFileWith :: 71 | String 72 | -> Pipe Text a IO (DecodingRowError Headed Text) 73 | -> Assertion 74 | streamFileWith filename decodingPipe = do 75 | r <- withFile filename ReadMode $ \h -> runEffect $ 76 | fmap (SD.convertDecodeError "utf-8") (PT.decode (PT.utf8 . PT.eof) $ PB.fromHandle h) 77 | >-> fmap Just decodingPipe 78 | >-> Pipes.drain 79 | case r of 80 | Nothing -> assertBool "impossible" True 81 | Just err -> assertFailure (Decoding.prettyError Text.unpack err) 82 | 83 | -- let dirPiece = case xs of 84 | -- ["full"] -> "large/" 85 | -- _ -> "small/" 86 | -- fullDirName = "data/" ++ dirPiece 87 | -- errMsg = concat 88 | -- [ "The " 89 | -- , fullDirName 90 | -- , " directory does not exist in the geolite project" 91 | -- ] 92 | -------------------------------------------------------------------------------- /lucid-colonnade/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Andrew Martin (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Andrew Martin nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /lucid-colonnade/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /lucid-colonnade/lucid-colonnade.cabal: -------------------------------------------------------------------------------- 1 | name: lucid-colonnade 2 | version: 1.0.1 3 | synopsis: Helper functions for using lucid with colonnade 4 | description: Lucid and colonnade 5 | homepage: https://github.com/andrewthad/colonnade#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Andrew Martin 9 | maintainer: andrew.thaddeus@gmail.com 10 | copyright: 2017 Andrew Martin 11 | category: web 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | 15 | library 16 | hs-source-dirs: src 17 | exposed-modules: 18 | Lucid.Colonnade 19 | build-depends: 20 | base >= 4.8 && < 5 21 | , colonnade >= 1.1.1 && < 1.3 22 | , lucid >= 2.9 && < 3.0 23 | , text >= 1.2 && < 2.1 24 | , vector >= 0.10 && < 0.14 25 | default-language: Haskell2010 26 | 27 | source-repository head 28 | type: git 29 | location: https://github.com/andrewthad/colonnade 30 | -------------------------------------------------------------------------------- /lucid-colonnade/src/Lucid/Colonnade.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | -- | Build HTML tables using @lucid@ and @colonnade@. It is 7 | -- recommended that users read the documentation for @colonnade@ first, 8 | -- since this library builds on the abstractions introduced there. 9 | -- Also, look at the docs for @blaze-colonnade@. These two 10 | -- libraries are similar, but blaze offers an HTML pretty printer 11 | -- which makes it possible to doctest examples. Since lucid 12 | -- does not offer such facilities, examples are omitted here. 13 | module Lucid.Colonnade 14 | ( -- * Apply 15 | encodeHtmlTable 16 | , encodeCellTable 17 | , encodeCellTableSized 18 | , encodeTable 19 | -- * Cell 20 | -- $build 21 | , Cell(..) 22 | , htmlCell 23 | , stringCell 24 | , textCell 25 | , lazyTextCell 26 | , builderCell 27 | , htmlFromCell 28 | , encodeBodySized 29 | , sectioned 30 | -- * Discussion 31 | -- $discussion 32 | ) where 33 | 34 | import Colonnade (Colonnade,Headed,Headless,Fascia,Cornice) 35 | import Data.Text (Text) 36 | import Control.Monad 37 | import Data.Semigroup 38 | import Data.Monoid hiding ((<>)) 39 | import Data.Foldable 40 | import Data.String (IsString(..)) 41 | import Data.Maybe (listToMaybe) 42 | import Data.Char (isSpace) 43 | import Control.Applicative (liftA2) 44 | import Lucid hiding (for_) 45 | import qualified Colonnade as Col 46 | import qualified Data.List as List 47 | import qualified Colonnade.Encode as E 48 | import qualified Data.Text as Text 49 | import qualified Data.Text.Lazy as LText 50 | import qualified Data.Text.Lazy.Builder as TBuilder 51 | import qualified Data.Vector as V 52 | import qualified Data.Text as T 53 | 54 | -- $build 55 | -- 56 | -- The 'Cell' type is used to build a 'Colonnade' that 57 | -- has 'Html' content inside table cells and may optionally 58 | -- have attributes added to the @\@ or @\@ elements 59 | -- that wrap this HTML content. 60 | 61 | -- | The attributes that will be applied to a @\@ and 62 | -- the HTML content that will go inside it. When using 63 | -- this type, remember that 'Attribute', defined in @blaze-markup@, 64 | -- is actually a collection of attributes, not a single attribute. 65 | data Cell d = Cell 66 | { cellAttribute :: ![Attribute] 67 | , cellHtml :: !(Html d) 68 | } 69 | 70 | instance (d ~ ()) => IsString (Cell d) where 71 | fromString = stringCell 72 | 73 | instance Semigroup d => Semigroup (Cell d) where 74 | Cell a1 c1 <> Cell a2 c2 = Cell (mappend a1 a2) (liftA2 (<>) c1 c2) 75 | 76 | instance Monoid d => Monoid (Cell d) where 77 | mempty = Cell mempty (return mempty) 78 | mappend = (<>) 79 | 80 | -- | Create a 'Cell' from a 'Widget' 81 | htmlCell :: Html d -> Cell d 82 | htmlCell = Cell mempty 83 | 84 | -- | Create a 'Cell' from a 'String' 85 | stringCell :: String -> Cell () 86 | stringCell = htmlCell . fromString 87 | 88 | -- | Create a 'Cell' from a 'Char' 89 | charCell :: Char -> Cell () 90 | charCell = stringCell . pure 91 | 92 | -- | Create a 'Cell' from a 'Text' 93 | textCell :: Text -> Cell () 94 | textCell = htmlCell . toHtml 95 | 96 | -- | Create a 'Cell' from a lazy text 97 | lazyTextCell :: LText.Text -> Cell () 98 | lazyTextCell = textCell . LText.toStrict 99 | 100 | -- | Create a 'Cell' from a text builder 101 | builderCell :: TBuilder.Builder -> Cell () 102 | builderCell = lazyTextCell . TBuilder.toLazyText 103 | 104 | -- | Encode a table. Table cell element do not have 105 | -- any attributes applied to them. 106 | encodeHtmlTable :: 107 | (E.Headedness h, Foldable f, Monoid d) 108 | => [Attribute] -- ^ Attributes of @\@ element 109 | -> Colonnade h a (Html d) -- ^ How to encode data as columns 110 | -> f a -- ^ Collection of data 111 | -> Html d 112 | encodeHtmlTable = encodeTable 113 | (E.headednessPure ([],[])) mempty (const mempty) (\el -> el []) 114 | 115 | -- | Encode a table. Table cells may have attributes applied 116 | -- to them 117 | encodeCellTable :: 118 | (E.Headedness h, Foldable f, Monoid d) 119 | => [Attribute] -- ^ Attributes of @\@ element 120 | -> Colonnade h a (Cell d) -- ^ How to encode data as columns 121 | -> f a -- ^ Collection of data 122 | -> Html d 123 | encodeCellTable = encodeTable 124 | (E.headednessPure ([],[])) mempty (const mempty) htmlFromCell 125 | 126 | encodeCellTableSized :: 127 | (E.Headedness h, Foldable f, Monoid d) 128 | => [Attribute] -- ^ Attributes of @\@ element 129 | -> Colonnade (E.Sized Int h) a (Cell d) -- ^ How to encode data as columns 130 | -> f a -- ^ Collection of data 131 | -> Html () 132 | encodeCellTableSized = encodeTableSized 133 | (E.headednessPure ([],[])) mempty (const mempty) htmlFromCell 134 | 135 | -- | Encode a table. This handles a very general case and 136 | -- is seldom needed by users. One of the arguments provided is 137 | -- used to add attributes to the generated @\@ elements. 138 | -- The elements of type @d@ produced by generating html are 139 | -- strictly combined with their monoidal append function. 140 | -- However, this type is nearly always @()@. 141 | encodeTable :: forall f h a d c. 142 | (Foldable f, E.Headedness h, Monoid d) 143 | => h ([Attribute],[Attribute]) -- ^ Attributes of @\@ and its @\@ 144 | -> [Attribute] -- ^ Attributes of @\@ element 145 | -> (a -> [Attribute]) -- ^ Attributes of each @\@ element 146 | -> (([Attribute] -> Html d -> Html d) -> c -> Html d) -- ^ Wrap content and convert to 'Html' 147 | -> [Attribute] -- ^ Attributes of @\@ element 148 | -> Colonnade h a c -- ^ How to encode data as a row 149 | -> f a -- ^ Collection of data 150 | -> Html d 151 | encodeTable mtheadAttrs tbodyAttrs trAttrs wrapContent tableAttrs colonnade xs = 152 | table_ tableAttrs $ do 153 | d1 <- case E.headednessExtractForall of 154 | Nothing -> return mempty 155 | Just extractForall -> do 156 | let (theadAttrs,theadTrAttrs) = extract mtheadAttrs 157 | thead_ theadAttrs $ tr_ theadTrAttrs $ do 158 | foldlMapM' (wrapContent th_ . extract . E.oneColonnadeHead) (E.getColonnade colonnade) 159 | where 160 | extract :: forall y. h y -> y 161 | extract = E.runExtractForall extractForall 162 | d2 <- encodeBody trAttrs wrapContent tbodyAttrs colonnade xs 163 | return (mappend d1 d2) 164 | 165 | encodeBody :: (Foldable f, Monoid d) 166 | => (a -> [Attribute]) -- ^ Attributes of each @\@ element 167 | -> (([Attribute] -> Html d -> Html d) -> c -> Html d) -- ^ Wrap content and convert to 'Html' 168 | -> [Attribute] -- ^ Attributes of @\@ element 169 | -> Colonnade h a c -- ^ How to encode data as a row 170 | -> f a -- ^ Collection of data 171 | -> Html d 172 | encodeBody trAttrs wrapContent tbodyAttrs colonnade xs = do 173 | tbody_ tbodyAttrs $ do 174 | flip foldlMapM' xs $ \x -> do 175 | tr_ (trAttrs x) $ E.rowMonadic colonnade (wrapContent td_) x 176 | 177 | encodeBodySized :: 178 | (Foldable f, Monoid d) 179 | => (a -> [Attribute]) 180 | -> [Attribute] 181 | -> Colonnade (E.Sized Int h) a (Cell d) 182 | -> f a 183 | -> Html () 184 | encodeBodySized trAttrs tbodyAttrs colonnade collection = tbody_ tbodyAttrs $ do 185 | for_ collection $ \a -> tr_ (trAttrs a) $ do 186 | E.rowMonoidalHeader 187 | colonnade 188 | (\(E.Sized sz _) (Cell cattr content) -> 189 | void $ td_ (setColspanOrHide sz cattr) content 190 | ) 191 | a 192 | 193 | encodeTableSized :: forall f h a d c. 194 | (Foldable f, E.Headedness h, Monoid d) 195 | => h ([Attribute],[Attribute]) -- ^ Attributes of @\@ and its @\@ 196 | -> [Attribute] -- ^ Attributes of @\@ element 197 | -> (a -> [Attribute]) -- ^ Attributes of each @\@ element 198 | -> (([Attribute] -> Html d -> Html d) -> (Cell d) -> Html d) -- ^ Wrap content and convert to 'Html' 199 | -> [Attribute] -- ^ Attributes of @\@ element 200 | -> Colonnade (E.Sized Int h) a (Cell d) -- ^ How to encode data as a row 201 | -> f a -- ^ Collection of data 202 | -> Html () 203 | encodeTableSized mtheadAttrs tbodyAttrs trAttrs wrapContent tableAttrs colonnade xs = 204 | table_ tableAttrs $ do 205 | d1 <- case E.headednessExtractForall of 206 | Nothing -> pure mempty 207 | Just extractForall -> do 208 | let (theadAttrs,theadTrAttrs) = extract mtheadAttrs 209 | thead_ theadAttrs $ tr_ theadTrAttrs $ do 210 | traverse_ 211 | (wrapContent th_ . extract . 212 | (\(E.Sized i h) -> case E.headednessExtract of 213 | Just f -> 214 | let (Cell attrs content) = f h 215 | in E.headednessPure $ Cell (setColspanOrHide i attrs) content 216 | Nothing -> E.headednessPure mempty 217 | -- (E.Headed (Cell attrs content)) -> E.Headed $ Cell (setColspanOrHide i attrs) content 218 | -- E.Headless -> E.Headless 219 | ) 220 | . E.oneColonnadeHead 221 | ) 222 | (E.getColonnade colonnade) 223 | where 224 | extract :: forall y. h y -> y 225 | extract = E.runExtractForall extractForall 226 | encodeBodySized trAttrs tbodyAttrs colonnade xs 227 | 228 | setColspanOrHide :: Int -> [Attribute] -> [Attribute] 229 | setColspanOrHide i attrs 230 | | i < 1 = style_ "display:none;" : attrs 231 | | otherwise = colspan_ (Text.pack (show i)) : attrs 232 | 233 | foldlMapM' :: forall g b a m. (Foldable g, Monoid b, Monad m) => (a -> m b) -> g a -> m b 234 | foldlMapM' f xs = foldr f' pure xs mempty 235 | where 236 | f' :: a -> (b -> m b) -> b -> m b 237 | f' x k bl = do 238 | br <- f x 239 | let !b = mappend bl br 240 | k b 241 | 242 | -- | Convert a 'Cell' to 'Html' by wrapping the content with a tag 243 | -- and applying the 'Cell' attributes to that tag. 244 | htmlFromCell :: ([Attribute] -> Html d -> Html d) -> Cell d -> Html d 245 | htmlFromCell f (Cell attr content) = f attr content 246 | 247 | -- $discussion 248 | -- 249 | -- In this module, some of the functions for applying a 'Colonnade' to 250 | -- some values to build a table have roughly this type signature: 251 | -- 252 | -- > Foldable a => Colonnade Headedness a (Cell d) -> f a -> Html d 253 | -- 254 | -- The 'Colonnade' content type is 'Cell', but the content 255 | -- type of the result is 'Html'. It may not be immidiately clear why 256 | -- this is done. Another strategy, which this library also 257 | -- uses, is to write 258 | -- these functions to take a 'Colonnade' whose content is 'Html': 259 | -- 260 | -- > Foldable a => Colonnade Headedness a (Html d) -> f a -> Html d 261 | -- 262 | -- When the 'Colonnade' content type is 'Html', then the header 263 | -- content is rendered as the child of a @\@ and the row 264 | -- content the child of a @\@. However, it is not possible 265 | -- to add attributes to these parent elements. To accomodate this 266 | -- situation, it is necessary to introduce 'Cell', which includes 267 | -- the possibility of attributes on the parent node. 268 | 269 | sectioned :: 270 | (Foldable f, E.Headedness h, Foldable g, Monoid c) 271 | => [Attribute] -- ^ @\@ tag attributes 272 | -> Maybe ([Attribute], [Attribute]) 273 | -- ^ Attributes of @\@ and its @\@, pass 'Nothing' to omit @\@ 274 | -> [Attribute] -- ^ @\@ tag attributes 275 | -> (a -> [Attribute]) -- ^ @\@ tag attributes for data rows 276 | -> (b -> Cell c) -- ^ Section divider encoding strategy 277 | -> Colonnade h a (Cell c) -- ^ Data encoding strategy 278 | -> f (b, g a) -- ^ Collection of data 279 | -> Html () 280 | sectioned tableAttrs mheadAttrs bodyAttrs trAttrs dividerContent colonnade@(E.Colonnade v) collection = do 281 | let vlen = V.length v 282 | table_ tableAttrs $ do 283 | for_ mheadAttrs $ \(headAttrs,headTrAttrs) -> 284 | thead_ headAttrs . tr_ headTrAttrs $ 285 | E.headerMonadicGeneral_ colonnade (htmlFromCell th_) 286 | tbody_ bodyAttrs $ for_ collection $ \(b,as) -> do 287 | let Cell attrs contents = dividerContent b 288 | tr_ [] $ do 289 | td_ ((colspan_ $ T.pack (show vlen)): attrs) contents 290 | flip traverse_ as $ \a -> do 291 | tr_ (trAttrs a) $ E.rowMonadic colonnade (htmlFromCell td_) a 292 | 293 | -------------------------------------------------------------------------------- /projects/cabal-8.0.2.project: -------------------------------------------------------------------------------- 1 | packages: ./colonnade 2 | ./blaze-colonnade 3 | ./lucid-colonnade 4 | ./yesod-colonnade 5 | -------------------------------------------------------------------------------- /projects/cabal-8.2.2.project: -------------------------------------------------------------------------------- 1 | packages: ./colonnade 2 | ./blaze-colonnade 3 | ./lucid-colonnade 4 | ./yesod-colonnade 5 | -------------------------------------------------------------------------------- /projects/cabal-8.4.3.project: -------------------------------------------------------------------------------- 1 | packages: ./colonnade 2 | ./blaze-colonnade 3 | ./lucid-colonnade 4 | -------------------------------------------------------------------------------- /siphon/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for siphon 2 | 3 | ## 0.8.2.0 -- 2022-??-?? 4 | 5 | * Add 6 | 7 | ## 0.8.1.2 -- 2021-10-25 8 | 9 | * Correct handling of CRLF. 10 | -------------------------------------------------------------------------------- /siphon/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Andrew Martin (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Andrew Martin nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /siphon/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /siphon/hackage-docs.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | 4 | if [ "$#" -ne 1 ]; then 5 | echo "Usage: scripts/hackage-docs.sh HACKAGE_USER" 6 | exit 1 7 | fi 8 | 9 | user=$1 10 | 11 | cabal_file=$(find . -maxdepth 1 -name "*.cabal" -print -quit) 12 | if [ ! -f "$cabal_file" ]; then 13 | echo "Run this script in the top-level package directory" 14 | exit 1 15 | fi 16 | 17 | pkg=$(awk -F ":[[:space:]]*" 'tolower($1)=="name" { print $2 }' < "$cabal_file") 18 | ver=$(awk -F ":[[:space:]]*" 'tolower($1)=="version" { print $2 }' < "$cabal_file") 19 | 20 | if [ -z "$pkg" ]; then 21 | echo "Unable to determine package name" 22 | exit 1 23 | fi 24 | 25 | if [ -z "$ver" ]; then 26 | echo "Unable to determine package version" 27 | exit 1 28 | fi 29 | 30 | echo "Detected package: $pkg-$ver" 31 | 32 | dir=$(mktemp -d build-docs.XXXXXX) 33 | trap 'rm -r "$dir"' EXIT 34 | 35 | # cabal haddock --hoogle --hyperlink-source --html-location='/package/$pkg-$version/docs' --contents-location='/package/$pkg-$version' 36 | stack haddock 37 | 38 | cp -R .stack-work/dist/x86_64-linux/Cabal-1.22.5.0/doc/html/$pkg/ $dir/$pkg-$ver-docs 39 | # /home/andrew/.stack/snapshots/x86_64-linux/lts-5.17/7.10.3/doc/index.html 40 | 41 | tar cvz -C $dir --format=ustar -f $dir/$pkg-$ver-docs.tar.gz $pkg-$ver-docs 42 | 43 | curl -X PUT \ 44 | -H 'Content-Type: application/x-tar' \ 45 | -H 'Content-Encoding: gzip' \ 46 | -u "$user" \ 47 | --data-binary "@$dir/$pkg-$ver-docs.tar.gz" \ 48 | "https://hackage.haskell.org/package/$pkg-$ver/docs" 49 | -------------------------------------------------------------------------------- /siphon/siphon.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: siphon 3 | version: 0.8.2.0 4 | synopsis: Encode and decode CSV files 5 | description: Please see README.md 6 | homepage: https://github.com/andrewthad/colonnade#readme 7 | license: BSD-3-Clause 8 | license-file: LICENSE 9 | author: Andrew Martin 10 | maintainer: andrew.thaddeus@gmail.com 11 | copyright: 2016 Andrew Martin 12 | category: web 13 | build-type: Simple 14 | extra-source-files: CHANGELOG.md 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: 19 | Siphon 20 | Siphon.Types 21 | build-depends: 22 | base >= 4.8 && < 5 23 | , colonnade >= 1.2 && < 1.3 24 | , text >= 1.0 && < 2.1 25 | , bytestring 26 | , vector 27 | , streaming >= 0.1.4 && < 0.3 28 | , attoparsec 29 | , transformers >= 0.4.2 && < 0.8 30 | , semigroups >= 0.18.2 && < 0.21 31 | default-language: Haskell2010 32 | 33 | test-suite test 34 | type: exitcode-stdio-1.0 35 | hs-source-dirs: test 36 | main-is: Test.hs 37 | build-depends: 38 | base 39 | , HUnit 40 | , QuickCheck 41 | , bytestring 42 | , colonnade 43 | , contravariant 44 | , either 45 | , pipes 46 | , profunctors 47 | , siphon 48 | , streaming 49 | , test-framework 50 | , test-framework-hunit 51 | , test-framework-quickcheck2 52 | , text 53 | , vector 54 | default-language: Haskell2010 55 | 56 | source-repository head 57 | type: git 58 | location: https://github.com/andrewthad/colonnade 59 | -------------------------------------------------------------------------------- /siphon/src/Siphon.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | 6 | {-# OPTIONS_GHC -Wall -fno-warn-unused-imports #-} 7 | 8 | -- | Build CSVs using the abstractions provided in the @colonnade@ library, and 9 | -- parse CSVs using 'Siphon', which is the dual of 'Colonnade'. 10 | -- Read the documentation for @colonnade@ before reading the documentation 11 | -- for @siphon@. All of the examples on this page assume a common set of 12 | -- imports that are provided at the bottom of this page. 13 | module Siphon 14 | ( -- * Encode CSV 15 | encodeCsv 16 | , encodeCsvStream 17 | , encodeCsvUtf8 18 | , encodeCsvStreamUtf8 19 | -- * Decode CSV 20 | , decodeCsvUtf8 21 | , decodeHeadedCsvUtf8 22 | , decodeIndexedCsvUtf8 23 | -- * Build Siphon 24 | , headed 25 | , headless 26 | , indexed 27 | -- * Types 28 | , Siphon 29 | , SiphonError(..) 30 | , Indexed(..) 31 | -- * For Testing 32 | , headedToIndexed 33 | -- * Utility 34 | , humanizeSiphonError 35 | , eqSiphonHeaders 36 | , showSiphonHeaders 37 | -- * Imports 38 | -- $setup 39 | ) where 40 | 41 | import Siphon.Types 42 | import Data.Monoid 43 | import Control.Applicative 44 | import Control.Monad 45 | import Data.Functor.Classes (Eq1,Show1,liftEq,showsPrec1) 46 | 47 | import qualified Data.ByteString.Char8 as BC8 48 | import qualified Data.Attoparsec.ByteString as A 49 | import qualified Data.Attoparsec.Lazy as AL 50 | import qualified Data.Attoparsec.Zepto as Z 51 | import qualified Data.ByteString as S 52 | import qualified Data.ByteString.Unsafe as S 53 | import qualified Data.Vector as V 54 | import qualified Data.ByteString as B 55 | import qualified Data.ByteString.Lazy as LByteString 56 | import qualified Data.ByteString.Builder as Builder 57 | import qualified Data.Text.Lazy as LT 58 | import qualified Data.Text.Lazy.Builder as TB 59 | import qualified Data.Text as T 60 | import qualified Data.List as L 61 | import qualified Streaming as SM 62 | import qualified Streaming.Prelude as SMP 63 | import qualified Data.Attoparsec.Types as ATYP 64 | import qualified Colonnade.Encode as CE 65 | import qualified Data.Vector.Mutable as MV 66 | import qualified Data.ByteString.Builder as BB 67 | import qualified Data.Semigroup as SG 68 | 69 | import Control.Monad.Trans.Class 70 | import Data.Functor.Identity (Identity(..)) 71 | import Data.ByteString.Builder (toLazyByteString,byteString) 72 | import Data.Attoparsec.ByteString.Char8 (char, endOfInput, string) 73 | import Data.Word (Word8) 74 | import Data.Vector (Vector) 75 | import Data.ByteString (ByteString) 76 | import Data.Coerce (coerce) 77 | import Data.Char (chr) 78 | import Data.Text.Encoding (decodeUtf8') 79 | import Streaming (Stream,Of(..)) 80 | import Data.Vector.Mutable (MVector) 81 | import Control.Monad.ST 82 | import Data.Text (Text) 83 | import Data.Semigroup (Semigroup) 84 | 85 | newtype Escaped c = Escaped { getEscaped :: c } 86 | data Ended = EndedYes | EndedNo 87 | deriving (Show) 88 | data CellResult c = CellResultData !c | CellResultNewline !c !Ended 89 | deriving (Show) 90 | 91 | -- | Backwards-compatibility alias for 'decodeHeadedCsvUtf8'. 92 | decodeCsvUtf8 :: Monad m 93 | => Siphon CE.Headed ByteString a 94 | -> Stream (Of ByteString) m () -- ^ encoded csv 95 | -> Stream (Of a) m (Maybe SiphonError) 96 | decodeCsvUtf8 = decodeHeadedCsvUtf8 97 | 98 | -- | Decode a CSV whose first row is contains headers identify each column. 99 | decodeHeadedCsvUtf8 :: Monad m 100 | => Siphon CE.Headed ByteString a 101 | -> Stream (Of ByteString) m () -- ^ encoded csv 102 | -> Stream (Of a) m (Maybe SiphonError) 103 | decodeHeadedCsvUtf8 headedSiphon s1 = do 104 | e <- lift (consumeHeaderRowUtf8 s1) 105 | case e of 106 | Left err -> return (Just err) 107 | Right (v :> s2) -> case headedToIndexed utf8ToStr v headedSiphon of 108 | Left err -> return (Just err) 109 | Right ixedSiphon -> do 110 | let requiredLength = V.length v 111 | consumeBodyUtf8 1 requiredLength ixedSiphon s2 112 | 113 | -- | Decode a CSV without a header. 114 | decodeIndexedCsvUtf8 :: Monad m 115 | => Int -- ^ How many columns are there? This number should be greater than any indices referenced by the scheme. 116 | -> Siphon Indexed ByteString a 117 | -> Stream (Of ByteString) m () -- ^ encoded csv 118 | -> Stream (Of a) m (Maybe SiphonError) 119 | decodeIndexedCsvUtf8 !requiredLength ixedSiphon s1 = do 120 | consumeBodyUtf8 0 requiredLength ixedSiphon s1 121 | 122 | encodeCsvStreamUtf8 :: (Monad m, CE.Headedness h) 123 | => CE.Colonnade h a ByteString 124 | -> Stream (Of a) m r 125 | -> Stream (Of ByteString) m r 126 | encodeCsvStreamUtf8 = 127 | encodeCsvInternal escapeChar8 (B.singleton comma) (B.singleton newline) 128 | 129 | -- | Streaming variant of 'encodeCsv'. This is particularly useful 130 | -- when you need to produce millions of rows without having them 131 | -- all loaded into memory at the same time. 132 | encodeCsvStream :: (Monad m, CE.Headedness h) 133 | => CE.Colonnade h a Text 134 | -> Stream (Of a) m r 135 | -> Stream (Of Text) m r 136 | encodeCsvStream = 137 | encodeCsvInternal textEscapeChar8 (T.singleton ',') (T.singleton '\n') 138 | 139 | -- | Encode a collection to a CSV as a text 'TB.Builder'. For example, 140 | -- we can take the following columnar encoding of a person: 141 | -- 142 | -- >>> :{ 143 | -- let colPerson :: Colonnade Headed Person Text 144 | -- colPerson = mconcat 145 | -- [ C.headed "Name" name 146 | -- , C.headed "Age" (T.pack . show . age) 147 | -- , C.headed "Company" (fromMaybe "N/A" . company) 148 | -- ] 149 | -- :} 150 | -- 151 | -- And we have the following people whom we wish to encode 152 | -- in this way: 153 | -- 154 | -- >>> :{ 155 | -- let people :: [Person] 156 | -- people = 157 | -- [ Person "Chao" 26 (Just "Tectonic, Inc.") 158 | -- , Person "Elsie" 41 (Just "Globex Corporation") 159 | -- , Person "Arabella" 19 Nothing 160 | -- ] 161 | -- :} 162 | -- 163 | -- We pair the encoding with the rows to get a CSV: 164 | -- 165 | -- >>> LTIO.putStr (TB.toLazyText (encodeCsv colPerson people)) 166 | -- Name,Age,Company 167 | -- Chao,26,"Tectonic, Inc." 168 | -- Elsie,41,Globex Corporation 169 | -- Arabella,19,N/A 170 | encodeCsv :: (Foldable f, CE.Headedness h) 171 | => CE.Colonnade h a Text -- ^ Tablular encoding 172 | -> f a -- ^ Value of each row 173 | -> TB.Builder 174 | encodeCsv enc = 175 | textStreamToBuilder . encodeCsvStream enc . SMP.each 176 | 177 | -- | Encode a collection to a CSV as a bytestring 'BB.Builder'. 178 | encodeCsvUtf8 :: (Foldable f, CE.Headedness h) 179 | => CE.Colonnade h a ByteString -- ^ Tablular encoding 180 | -> f a -- ^ Value of each row 181 | -> BB.Builder 182 | encodeCsvUtf8 enc = 183 | streamToBuilder . encodeCsvStreamUtf8 enc . SMP.each 184 | 185 | streamToBuilder :: Stream (Of ByteString) Identity () -> BB.Builder 186 | streamToBuilder s = SM.destroy s 187 | (\(bs :> bb) -> BB.byteString bs <> bb) runIdentity (\() -> mempty) 188 | 189 | textStreamToBuilder :: Stream (Of Text) Identity () -> TB.Builder 190 | textStreamToBuilder s = SM.destroy s 191 | (\(bs :> bb) -> TB.fromText bs <> bb) runIdentity (\() -> mempty) 192 | 193 | encodeCsvInternal :: (Monad m, CE.Headedness h) 194 | => (c -> Escaped c) 195 | -> c -- ^ separator 196 | -> c -- ^ newline 197 | -> CE.Colonnade h a c 198 | -> Stream (Of a) m r 199 | -> Stream (Of c) m r 200 | encodeCsvInternal escapeFunc separatorStr newlineStr colonnade s = do 201 | case CE.headednessExtract of 202 | Just toContent -> encodeHeader toContent escapeFunc separatorStr newlineStr colonnade 203 | Nothing -> return () 204 | encodeRows escapeFunc separatorStr newlineStr colonnade s 205 | 206 | encodeHeader :: Monad m 207 | => (h c -> c) 208 | -> (c -> Escaped c) 209 | -> c -- ^ separator 210 | -> c -- ^ newline 211 | -> CE.Colonnade h a c 212 | -> Stream (Of c) m () 213 | encodeHeader toContent escapeFunc separatorStr newlineStr colonnade = do 214 | let (vs,ws) = V.splitAt 1 (CE.getColonnade colonnade) 215 | -- we only need to do this split because the first cell 216 | -- gets treated differently than the others. It does not 217 | -- get a separator added before it. 218 | V.forM_ vs $ \(CE.OneColonnade h _) -> do 219 | SMP.yield (getEscaped (escapeFunc (toContent h))) 220 | V.forM_ ws $ \(CE.OneColonnade h _) -> do 221 | SMP.yield separatorStr 222 | SMP.yield (getEscaped (escapeFunc (toContent h))) 223 | SMP.yield newlineStr 224 | 225 | mapStreamM :: Monad m 226 | => (a -> Stream (Of b) m x) 227 | -> Stream (Of a) m r 228 | -> Stream (Of b) m r 229 | mapStreamM f = SM.concats . SM.mapsM (\(a :> s) -> return (f a >> return s)) 230 | 231 | encodeRows :: Monad m 232 | => (c -> Escaped c) 233 | -> c -- ^ separator 234 | -> c -- ^ newline 235 | -> CE.Colonnade f a c 236 | -> Stream (Of a) m r 237 | -> Stream (Of c) m r 238 | encodeRows escapeFunc separatorStr newlineStr colonnade = mapStreamM $ \a -> do 239 | let (vs,ws) = V.splitAt 1 (CE.getColonnade colonnade) 240 | -- we only need to do this split because the first cell 241 | -- gets treated differently than the others. It does not 242 | -- get a separator added before it. 243 | V.forM_ vs $ \(CE.OneColonnade _ encode) -> SMP.yield (getEscaped (escapeFunc (encode a))) 244 | V.forM_ ws $ \(CE.OneColonnade _ encode) -> do 245 | SMP.yield separatorStr 246 | SMP.yield (getEscaped (escapeFunc (encode a))) 247 | SMP.yield newlineStr 248 | 249 | -- | Maps over a 'Decolonnade' that expects headers, converting these 250 | -- expected headers into the indices of the columns that they 251 | -- correspond to. 252 | headedToIndexed :: forall c a. Eq c 253 | => (c -> T.Text) 254 | -> Vector c -- ^ Headers in the source document 255 | -> Siphon CE.Headed c a -- ^ Decolonnade that contains expected headers 256 | -> Either SiphonError (Siphon Indexed c a) 257 | headedToIndexed toStr v = 258 | mapLeft (\(HeaderErrors a b c) -> SiphonError 0 (RowErrorHeaders a b c)) 259 | . getEitherWrap 260 | . go 261 | where 262 | go :: forall b. 263 | Siphon CE.Headed c b 264 | -> EitherWrap HeaderErrors (Siphon Indexed c b) 265 | go (SiphonPure b) = EitherWrap (Right (SiphonPure b)) 266 | go (SiphonAp (CE.Headed h) decode apNext) = 267 | let rnext = go apNext 268 | ixs = V.elemIndices h v 269 | ixsLen = V.length ixs 270 | rcurrent 271 | | ixsLen == 1 = Right (ixs V.! 0) 272 | | ixsLen == 0 = Left (HeaderErrors V.empty (V.singleton (toStr h)) V.empty) 273 | | otherwise = 274 | let dups = V.singleton (V.map (\ix -> CellError ix (toStr (v V.! ix) {- (V.unsafeIndex v ix) -} )) ixs) 275 | in Left (HeaderErrors dups V.empty V.empty) 276 | in (\ix nextSiphon -> SiphonAp (Indexed ix) decode nextSiphon) 277 | <$> EitherWrap rcurrent 278 | <*> rnext 279 | 280 | data HeaderErrors = HeaderErrors !(Vector (Vector CellError)) !(Vector T.Text) !(Vector Int) 281 | 282 | instance Semigroup HeaderErrors where 283 | HeaderErrors a1 b1 c1 <> HeaderErrors a2 b2 c2 = HeaderErrors 284 | (mappend a1 a2) (mappend b1 b2) (mappend c1 c2) 285 | 286 | instance Monoid HeaderErrors where 287 | mempty = HeaderErrors mempty mempty mempty 288 | mappend = (SG.<>) 289 | 290 | -- byteStringChar8 :: Siphon ByteString 291 | -- byteStringChar8 = Siphon 292 | -- escape 293 | -- encodeRow 294 | -- (A.parse (row comma)) 295 | -- B.null 296 | 297 | escapeChar8 :: ByteString -> Escaped ByteString 298 | escapeChar8 t = case B.find (\c -> c == newline || c == cr || c == comma || c == doubleQuote) t of 299 | Nothing -> Escaped t 300 | Just _ -> escapeAlways t 301 | 302 | textEscapeChar8 :: Text -> Escaped Text 303 | textEscapeChar8 t = case T.find (\c -> c == '\n' || c == '\r' || c == ',' || c == '"') t of 304 | Nothing -> Escaped t 305 | Just _ -> textEscapeAlways t 306 | 307 | -- This implementation is definitely suboptimal. 308 | -- A better option (which would waste a little space 309 | -- but would be much faster) would be to build the 310 | -- new bytestring by writing to a buffer directly. 311 | escapeAlways :: ByteString -> Escaped ByteString 312 | escapeAlways t = Escaped $ LByteString.toStrict $ Builder.toLazyByteString $ 313 | Builder.word8 doubleQuote 314 | <> B.foldl 315 | (\ acc b -> acc <> if b == doubleQuote 316 | then Builder.byteString 317 | (B.pack [doubleQuote,doubleQuote]) 318 | else Builder.word8 b) 319 | mempty 320 | t 321 | <> Builder.word8 doubleQuote 322 | 323 | -- Suboptimal for similar reason as escapeAlways. 324 | textEscapeAlways :: Text -> Escaped Text 325 | textEscapeAlways t = Escaped $ LT.toStrict $ TB.toLazyText $ 326 | TB.singleton '"' 327 | <> T.foldl 328 | (\ acc b -> acc <> if b == '"' 329 | then TB.fromString "\"\"" 330 | else TB.singleton b 331 | ) 332 | mempty 333 | t 334 | <> TB.singleton '"' 335 | 336 | -- Parse a record, not including the terminating line separator. The 337 | -- terminating line separate is not included as the last record in a 338 | -- CSV file is allowed to not have a terminating line separator. You 339 | -- most likely want to use the 'endOfLine' parser in combination with 340 | -- this parser. 341 | -- 342 | -- row :: Word8 -- ^ Field delimiter 343 | -- -> AL.Parser (Vector ByteString) 344 | -- row !delim = rowNoNewline delim <* endOfLine 345 | -- {-# INLINE row #-} 346 | -- 347 | -- rowNoNewline :: Word8 -- ^ Field delimiter 348 | -- -> AL.Parser (Vector ByteString) 349 | -- rowNoNewline !delim = V.fromList <$!> field delim `sepByDelim1'` delim 350 | -- {-# INLINE rowNoNewline #-} 351 | -- 352 | -- removeBlankLines :: [Vector ByteString] -> [Vector ByteString] 353 | -- removeBlankLines = filter (not . blankLine) 354 | 355 | 356 | -- | Parse a field. The field may be in either the escaped or 357 | -- non-escaped format. The return value is unescaped. This 358 | -- parser will consume the comma that comes after a field 359 | -- but not a newline that follows a field. If we are positioned 360 | -- at a newline when it starts, that newline will be consumed 361 | -- and we return CellResultNewline. 362 | field :: Word8 -> AL.Parser (CellResult ByteString) 363 | field !delim = do 364 | mb <- A.peekWord8 365 | -- We purposely don't use <|> as we want to commit to the first 366 | -- choice if we see a double quote. 367 | case mb of 368 | Just b 369 | | b == doubleQuote -> do 370 | (bs,tc) <- escapedField 371 | case tc of 372 | TrailCharComma -> return (CellResultData bs) 373 | TrailCharNewline -> return (CellResultNewline bs EndedNo) 374 | TrailCharEnd -> return (CellResultNewline bs EndedYes) 375 | | b == 10 || b == 13 -> do 376 | _ <- eatNewlines 377 | isEnd <- A.atEnd 378 | if isEnd 379 | then return (CellResultNewline B.empty EndedYes) 380 | else return (CellResultNewline B.empty EndedNo) 381 | | otherwise -> do 382 | (bs,tc) <- unescapedField delim 383 | case tc of 384 | TrailCharComma -> return (CellResultData bs) 385 | TrailCharNewline -> return (CellResultNewline bs EndedNo) 386 | TrailCharEnd -> return (CellResultNewline bs EndedYes) 387 | Nothing -> return (CellResultNewline B.empty EndedYes) 388 | {-# INLINE field #-} 389 | 390 | eatNewlines :: AL.Parser S.ByteString 391 | eatNewlines = A.takeWhile (\x -> x == 10 || x == 13) 392 | 393 | escapedField :: AL.Parser (S.ByteString,TrailChar) 394 | escapedField = do 395 | _ <- dquote 396 | -- The scan state is 'True' if the previous character was a double 397 | -- quote. We need to drop a trailing double quote left by scan. 398 | s <- S.init <$> 399 | ( A.scan False $ \s c -> 400 | if c == doubleQuote 401 | then Just (not s) 402 | else if s 403 | then Nothing 404 | else Just False 405 | ) 406 | mb <- A.peekWord8 407 | trailChar <- case mb of 408 | Just b 409 | | b == comma -> A.anyWord8 >> return TrailCharComma 410 | | b == newline -> A.anyWord8 >> return TrailCharNewline 411 | | b == cr -> do 412 | _ <- A.anyWord8 413 | _ <- A.word8 newline 414 | return TrailCharNewline 415 | | otherwise -> fail "encountered double quote after escaped field" 416 | Nothing -> return TrailCharEnd 417 | if doubleQuote `S.elem` s 418 | then case Z.parse unescape s of 419 | Right r -> return (r,trailChar) 420 | Left err -> fail err 421 | else return (s,trailChar) 422 | 423 | data TrailChar = TrailCharNewline | TrailCharComma | TrailCharEnd 424 | 425 | -- | Consume an unescaped field. If it ends with a newline, 426 | -- leave that in tact. If it ends with a comma, consume the comma. 427 | unescapedField :: Word8 -> AL.Parser (S.ByteString,TrailChar) 428 | unescapedField !delim = do 429 | bs <- A.takeWhile $ \c -> 430 | c /= doubleQuote && 431 | c /= newline && 432 | c /= delim && 433 | c /= cr 434 | mb <- A.peekWord8 435 | case mb of 436 | Just b 437 | | b == comma -> A.anyWord8 >> return (bs,TrailCharComma) 438 | | b == newline -> A.anyWord8 >> return (bs,TrailCharNewline) 439 | | b == cr -> do 440 | _ <- A.anyWord8 441 | _ <- A.word8 newline 442 | return (bs,TrailCharNewline) 443 | | otherwise -> fail "encountered double quote in unescaped field" 444 | Nothing -> return (bs,TrailCharEnd) 445 | 446 | dquote :: AL.Parser Char 447 | dquote = char '"' 448 | 449 | -- | This could be improved. We could avoid the builder and just 450 | -- write to a buffer directly. 451 | unescape :: Z.Parser S.ByteString 452 | unescape = (LByteString.toStrict . toLazyByteString) <$!> go mempty where 453 | go acc = do 454 | h <- Z.takeWhile (/= doubleQuote) 455 | let rest = do 456 | start <- Z.take 2 457 | if (S.unsafeHead start == doubleQuote && 458 | S.unsafeIndex start 1 == doubleQuote) 459 | then go (acc `mappend` byteString h `mappend` byteString (BC8.singleton '"')) 460 | else fail "invalid CSV escape sequence" 461 | done <- Z.atEnd 462 | if done 463 | then return (acc `mappend` byteString h) 464 | else rest 465 | 466 | doubleQuote, newline, cr, comma :: Word8 467 | doubleQuote = 34 468 | newline = 10 469 | cr = 13 470 | comma = 44 471 | 472 | -- | This adds one to the index because text editors consider 473 | -- line number to be one-based, not zero-based. 474 | humanizeSiphonError :: SiphonError -> String 475 | humanizeSiphonError (SiphonError ix e) = unlines 476 | $ ("Decolonnade error on line " ++ show (ix + 1) ++ " of file.") 477 | : ("Error Category: " ++ descr) 478 | : map (" " ++) errDescrs 479 | where (descr,errDescrs) = prettyRowError e 480 | 481 | prettyRowError :: RowError -> (String, [String]) 482 | prettyRowError x = case x of 483 | RowErrorParse -> (,) "CSV Parsing" 484 | [ "The cells were malformed." 485 | ] 486 | RowErrorSize reqLen actualLen -> (,) "Row Length" 487 | [ "Expected the row to have exactly " ++ show reqLen ++ " cells." 488 | , "The row only has " ++ show actualLen ++ " cells." 489 | ] 490 | RowErrorHeaderSize reqLen actualLen -> (,) "Minimum Header Length" 491 | [ "Expected the row to have at least " ++ show reqLen ++ " cells." 492 | , "The row only has " ++ show actualLen ++ " cells." 493 | ] 494 | RowErrorMalformed column -> (,) "Text Decolonnade" 495 | [ "Tried to decode input input in column " ++ columnNumToLetters column ++ " text" 496 | , "There is a mistake in the encoding of the text." 497 | ] 498 | RowErrorHeaders dupErrs namedErrs unnamedErrs -> (,) "Missing Headers" $ concat 499 | [ if V.length namedErrs > 0 then prettyNamedMissingHeaders namedErrs else [] 500 | , if V.length unnamedErrs > 0 then ["Missing unnamed headers"] else [] 501 | , if V.length dupErrs > 0 then prettyHeadingErrors dupErrs else [] 502 | ] 503 | RowErrorDecode errs -> (,) "Cell Decolonnade" (prettyCellErrors errs) 504 | 505 | prettyCellErrors :: Vector CellError -> [String] 506 | prettyCellErrors errs = drop 1 $ 507 | flip concatMap errs $ \(CellError ix content) -> 508 | let str = T.unpack content in 509 | [ "-----------" 510 | , "Column " ++ columnNumToLetters ix 511 | , "Cell Content Length: " ++ show (Prelude.length str) 512 | , "Cell Content: " ++ if null str 513 | then "[empty cell]" 514 | else str 515 | ] 516 | 517 | prettyNamedMissingHeaders :: Vector T.Text -> [String] 518 | prettyNamedMissingHeaders missing = concat 519 | [ concatMap (\h -> ["The header " ++ T.unpack h ++ " was missing."]) missing 520 | ] 521 | 522 | prettyHeadingErrors :: Vector (Vector CellError) -> [String] 523 | prettyHeadingErrors missing = join (V.toList (fmap f missing)) 524 | where 525 | f :: Vector CellError -> [String] 526 | f v 527 | | not (V.null w) && V.all (== V.head w) (V.tail w) = 528 | [ "The header [" 529 | , T.unpack (V.head w) 530 | , "] appears in columns " 531 | , L.intercalate ", " (V.toList (V.map (\(CellError ix _) -> columnNumToLetters ix) v)) 532 | ] 533 | | otherwise = multiMsg : V.toList 534 | (V.map (\(CellError ix content) -> " Column " ++ columnNumToLetters ix ++ ": " ++ T.unpack content) v) 535 | where 536 | w :: Vector T.Text 537 | w = V.map cellErrorContent v 538 | multiMsg :: String 539 | multiMsg = "Multiple headers matched the same predicate:" 540 | 541 | columnNumToLetters :: Int -> String 542 | columnNumToLetters i 543 | | i >= 0 && i < 25 = [chr (i + 65)] 544 | | otherwise = "Beyond Z. Fix this." 545 | 546 | newtype EitherWrap a b = EitherWrap 547 | { getEitherWrap :: Either a b 548 | } deriving (Functor) 549 | 550 | instance Monoid a => Applicative (EitherWrap a) where 551 | pure = EitherWrap . Right 552 | EitherWrap (Left a1) <*> EitherWrap (Left a2) = EitherWrap (Left (mappend a1 a2)) 553 | EitherWrap (Left a1) <*> EitherWrap (Right _) = EitherWrap (Left a1) 554 | EitherWrap (Right _) <*> EitherWrap (Left a2) = EitherWrap (Left a2) 555 | EitherWrap (Right f) <*> EitherWrap (Right b) = EitherWrap (Right (f b)) 556 | 557 | mapLeft :: (a -> b) -> Either a c -> Either b c 558 | mapLeft _ (Right a) = Right a 559 | mapLeft f (Left a) = Left (f a) 560 | 561 | consumeHeaderRowUtf8 :: Monad m 562 | => Stream (Of ByteString) m () 563 | -> m (Either SiphonError (Of (Vector ByteString) (Stream (Of ByteString) m ()))) 564 | consumeHeaderRowUtf8 = consumeHeaderRow (A.parse (field comma)) B.null B.empty (\() -> True) 565 | 566 | consumeBodyUtf8 :: forall m a. Monad m 567 | => Int -- ^ index of first row, usually zero or one 568 | -> Int -- ^ Required row length 569 | -> Siphon Indexed ByteString a 570 | -> Stream (Of ByteString) m () 571 | -> Stream (Of a) m (Maybe SiphonError) 572 | consumeBodyUtf8 = consumeBody utf8ToStr 573 | (A.parse (field comma)) B.null B.empty (\() -> True) 574 | 575 | utf8ToStr :: ByteString -> T.Text 576 | utf8ToStr = either (\_ -> T.empty) id . decodeUtf8' 577 | 578 | consumeHeaderRow :: forall m r c. Monad m 579 | => (c -> ATYP.IResult c (CellResult c)) 580 | -> (c -> Bool) -- ^ true if null string 581 | -> c 582 | -> (r -> Bool) -- ^ true if termination is acceptable 583 | -> Stream (Of c) m r 584 | -> m (Either SiphonError (Of (Vector c) (Stream (Of c) m r))) 585 | consumeHeaderRow parseCell isNull emptyStr isGood s0 = go 0 StrictListNil s0 586 | where 587 | go :: Int 588 | -> StrictList c 589 | -> Stream (Of c) m r 590 | -> m (Either SiphonError (Of (Vector c) (Stream (Of c) m r))) 591 | go !cellsLen !cells !s1 = do 592 | e <- skipWhile isNull s1 593 | case e of 594 | Left r -> return $ if isGood r 595 | then Right (reverseVectorStrictList cellsLen cells :> return r) 596 | else Left (SiphonError 0 RowErrorParse) 597 | Right (c :> s2) -> handleResult cellsLen cells (parseCell c) s2 598 | handleResult :: Int -> StrictList c 599 | -> ATYP.IResult c (CellResult c) 600 | -> Stream (Of c) m r 601 | -> m (Either SiphonError (Of (Vector c) (Stream (Of c) m r))) 602 | handleResult !cellsLen !cells !result s1 = case result of 603 | ATYP.Fail _ _ _ -> return $ Left $ SiphonError 0 RowErrorParse 604 | ATYP.Done !c1 !res -> case res of 605 | -- it might be wrong to ignore whether or not the stream has ended 606 | CellResultNewline cd _ -> do 607 | let v = reverseVectorStrictList (cellsLen + 1) (StrictListCons cd cells) 608 | return (Right (v :> (SMP.yield c1 >> s1))) 609 | CellResultData !cd -> if isNull c1 610 | then go (cellsLen + 1) (StrictListCons cd cells) s1 611 | else handleResult (cellsLen + 1) (StrictListCons cd cells) (parseCell c1) s1 612 | ATYP.Partial k -> do 613 | e <- skipWhile isNull s1 614 | case e of 615 | Left r -> handleResult cellsLen cells (k emptyStr) (return r) 616 | Right (c1 :> s2) -> handleResult cellsLen cells (k c1) s2 617 | 618 | consumeBody :: forall m r c a. Monad m 619 | => (c -> T.Text) 620 | -> (c -> ATYP.IResult c (CellResult c)) 621 | -> (c -> Bool) 622 | -> c 623 | -> (r -> Bool) -- ^ True if termination is acceptable. False if it is because of a decoding error. 624 | -> Int -- ^ index of first row, usually zero or one 625 | -> Int -- ^ Required row length 626 | -> Siphon Indexed c a 627 | -> Stream (Of c) m r 628 | -> Stream (Of a) m (Maybe SiphonError) 629 | consumeBody toStr parseCell isNull emptyStr isGood row0 reqLen siphon s0 = 630 | go row0 0 StrictListNil s0 631 | where 632 | go :: Int -> Int -> StrictList c -> Stream (Of c) m r -> Stream (Of a) m (Maybe SiphonError) 633 | go !row !cellsLen !cells !s1 = do 634 | e <- lift (skipWhile isNull s1) 635 | case e of 636 | Left r -> return $ if isGood r 637 | then Nothing 638 | else Just (SiphonError row RowErrorParse) 639 | Right (c :> s2) -> handleResult row cellsLen cells (parseCell c) s2 640 | handleResult :: Int -> Int -> StrictList c 641 | -> ATYP.IResult c (CellResult c) 642 | -> Stream (Of c) m r 643 | -> Stream (Of a) m (Maybe SiphonError) 644 | handleResult !row !cellsLen !cells !result s1 = case result of 645 | ATYP.Fail _ _ _ -> return $ Just $ SiphonError row RowErrorParse 646 | ATYP.Done !c1 !res -> case res of 647 | CellResultNewline !cd !ended -> do 648 | case decodeRow row (reverseVectorStrictList (cellsLen + 1) (StrictListCons cd cells)) of 649 | Left err -> return (Just err) 650 | Right a -> do 651 | SMP.yield a 652 | case ended of 653 | EndedYes -> do 654 | e <- lift (SM.inspect s1) 655 | case e of 656 | Left r -> return $ if isGood r 657 | then Nothing 658 | else Just (SiphonError row RowErrorParse) 659 | Right _ -> error "siphon: logical error, stream should be exhausted" 660 | EndedNo -> if isNull c1 661 | then go (row + 1) 0 StrictListNil s1 662 | else handleResult (row + 1) 0 StrictListNil (parseCell c1) s1 663 | CellResultData !cd -> if isNull c1 664 | then go row (cellsLen + 1) (StrictListCons cd cells) s1 665 | else handleResult row (cellsLen + 1) (StrictListCons cd cells) (parseCell c1) s1 666 | ATYP.Partial k -> do 667 | e <- lift (skipWhile isNull s1) 668 | case e of 669 | Left r -> handleResult row cellsLen cells (k emptyStr) (return r) 670 | Right (c1 :> s2) -> handleResult row cellsLen cells (k c1) s2 671 | decodeRow :: Int -> Vector c -> Either SiphonError a 672 | decodeRow rowIx v = 673 | let vlen = V.length v in 674 | if vlen /= reqLen 675 | then Left $ SiphonError rowIx $ RowErrorSize reqLen vlen 676 | else uncheckedRunWithRow toStr rowIx siphon v 677 | 678 | -- | You must pass the length of the list and as the first argument. 679 | -- Passing the wrong length will lead to an error. 680 | reverseVectorStrictList :: forall c. Int -> StrictList c -> Vector c 681 | reverseVectorStrictList len sl0 = V.create $ do 682 | mv <- MV.new len 683 | go1 mv 684 | return mv 685 | where 686 | go1 :: forall s. MVector s c -> ST s () 687 | go1 !mv = go2 (len - 1) sl0 688 | where 689 | go2 :: Int -> StrictList c -> ST s () 690 | go2 _ StrictListNil = return () 691 | go2 !ix (StrictListCons c slNext) = do 692 | MV.write mv ix c 693 | go2 (ix - 1) slNext 694 | 695 | 696 | skipWhile :: forall m a r. Monad m 697 | => (a -> Bool) 698 | -> Stream (Of a) m r 699 | -> m (Either r (Of a (Stream (Of a) m r))) 700 | skipWhile f = go where 701 | go :: Stream (Of a) m r 702 | -> m (Either r (Of a (Stream (Of a) m r))) 703 | go s1 = do 704 | e <- SM.inspect s1 705 | case e of 706 | Left _ -> return e 707 | Right (a :> s2) -> if f a 708 | then go s2 709 | else return e 710 | 711 | -- | Strict in the spine and in the values 712 | -- This is built in reverse and then reversed by reverseVectorStrictList 713 | -- when converting to a vector. 714 | data StrictList a = StrictListNil | StrictListCons !a !(StrictList a) 715 | 716 | -- | This function uses 'unsafeIndex' to access 717 | -- elements of the 'Vector'. 718 | uncheckedRunWithRow :: 719 | (c -> T.Text) 720 | -> Int 721 | -> Siphon Indexed c a 722 | -> Vector c 723 | -> Either SiphonError a 724 | uncheckedRunWithRow toStr i d v = 725 | mapLeft (SiphonError i . RowErrorDecode) (uncheckedRun toStr d v) 726 | 727 | -- | This function does not check to make sure that the indicies in 728 | -- the 'Decolonnade' are in the 'Vector'. Only use this if you have 729 | -- already verified that none of the indices in the siphon are 730 | -- out of the bounds. 731 | uncheckedRun :: forall c a. 732 | (c -> T.Text) 733 | -> Siphon Indexed c a 734 | -> Vector c 735 | -> Either (Vector CellError) a 736 | uncheckedRun toStr dc v = getEitherWrap (go dc) 737 | where 738 | go :: forall b. 739 | Siphon Indexed c b 740 | -> EitherWrap (Vector CellError) b 741 | go (SiphonPure b) = EitherWrap (Right b) 742 | go (SiphonAp (Indexed ix) decode apNext) = 743 | let rnext = go apNext 744 | content = v V.! ix -- V.unsafeIndex v ix 745 | rcurrent = maybe 746 | (Left (V.singleton (CellError ix (toStr content)))) 747 | Right 748 | (decode content) 749 | in rnext <*> (EitherWrap rcurrent) 750 | 751 | -- | Uses the argument to parse a CSV column. 752 | headless :: (c -> Maybe a) -> Siphon CE.Headless c a 753 | headless f = SiphonAp CE.Headless f (SiphonPure id) 754 | 755 | -- | Uses the second argument to parse a CSV column whose 756 | -- header content matches the first column exactly. 757 | headed :: c -> (c -> Maybe a) -> Siphon CE.Headed c a 758 | headed h f = SiphonAp (CE.Headed h) f (SiphonPure id) 759 | 760 | -- | Uses the second argument to parse a CSV column that 761 | -- is positioned at the index given by the first argument. 762 | indexed :: Int -> (c -> Maybe a) -> Siphon Indexed c a 763 | indexed ix f = SiphonAp (Indexed ix) f (SiphonPure id) 764 | 765 | eqSiphonHeaders :: (Eq1 f, Eq c) => Siphon f c a -> Siphon f c b -> Bool 766 | eqSiphonHeaders (SiphonPure _) (SiphonPure _) = True 767 | eqSiphonHeaders (SiphonAp h0 _ s0) (SiphonAp h1 _ s1) = 768 | liftEq (==) h0 h1 && eqSiphonHeaders s0 s1 769 | eqSiphonHeaders _ _ = False 770 | 771 | showSiphonHeaders :: (Show1 f, Show c) => Siphon f c a -> String 772 | showSiphonHeaders (SiphonPure _) = "" 773 | showSiphonHeaders (SiphonAp h0 _ s0) = showsPrec1 10 h0 (" :> " ++ showSiphonHeaders s0) 774 | 775 | -- $setup 776 | -- 777 | -- This code is copied from the head section. It has to be 778 | -- run before every set of tests. 779 | -- 780 | -- >>> :set -XOverloadedStrings 781 | -- >>> import Siphon (Siphon) 782 | -- >>> import Colonnade (Colonnade,Headed) 783 | -- >>> import qualified Siphon as S 784 | -- >>> import qualified Colonnade as C 785 | -- >>> import qualified Data.Text as T 786 | -- >>> import Data.Text (Text) 787 | -- >>> import qualified Data.Text.Lazy.IO as LTIO 788 | -- >>> import qualified Data.Text.Lazy.Builder as LB 789 | -- >>> import Data.Maybe (fromMaybe) 790 | -- >>> data Person = Person { name :: Text, age :: Int, company :: Maybe Text} 791 | 792 | -------------------------------------------------------------------------------- /siphon/src/Siphon/ByteString/Char8.hs: -------------------------------------------------------------------------------- 1 | module Siphon.ByteString.Char8 where 2 | -------------------------------------------------------------------------------- /siphon/src/Siphon/Content.hs: -------------------------------------------------------------------------------- 1 | module Siphon.Content 2 | ( byteStringChar8 3 | , text 4 | ) where 5 | 6 | import Siphon.Internal (byteStringChar8) 7 | import Siphon.Internal.Text (text) 8 | 9 | -------------------------------------------------------------------------------- /siphon/src/Siphon/Decoding.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE DeriveFunctor #-} 5 | 6 | module Siphon.Decoding 7 | ( mkParseError 8 | , headlessPipe 9 | , indexedPipe 10 | , headedPipe 11 | , consumeGeneral 12 | , pipeGeneral 13 | , convertDecodeError 14 | ) where 15 | 16 | import Siphon.Types 17 | import Colonnade (Headed(..),Headless(..)) 18 | import Siphon.Internal (row,comma) 19 | import Data.Text (Text) 20 | import Data.ByteString (ByteString) 21 | import Pipes (yield,Pipe,Consumer',Producer,await) 22 | import Data.Vector (Vector) 23 | import Data.Functor.Contravariant (Contravariant(..)) 24 | import Data.Char (chr) 25 | import qualified Data.Vector as Vector 26 | import qualified Data.Attoparsec.ByteString as AttoByteString 27 | import qualified Data.ByteString.Char8 as ByteString 28 | import qualified Data.Attoparsec.Types as Atto 29 | 30 | mkParseError :: Int -> [String] -> String -> DecolonnadeRowError f content 31 | mkParseError i ctxs msg = id 32 | $ DecolonnadeRowError i 33 | $ RowErrorParse $ concat 34 | [ "Contexts: [" 35 | , concat ctxs 36 | , "], Error Message: [" 37 | , msg 38 | , "]" 39 | ] 40 | 41 | -- | This is a convenience function for working with @pipes-text@. 42 | -- It will convert a UTF-8 decoding error into a `DecolonnadeRowError`, 43 | -- so the pipes can be properly chained together. 44 | convertDecodeError :: String -> Either (Producer ByteString m ()) () -> Maybe (DecolonnadeRowError f c) 45 | convertDecodeError encodingName (Left _) = Just (DecolonnadeRowError 0 (RowErrorMalformed encodingName)) 46 | convertDecodeError _ (Right ()) = Nothing 47 | 48 | -- | This is seldom useful but is included for completeness. 49 | headlessPipe :: Monad m 50 | => Siphon c 51 | -> Decolonnade Headless c a 52 | -> Pipe c a m (DecolonnadeRowError Headless c) 53 | headlessPipe sd decoding = uncheckedPipe requiredLength 0 sd indexedDecoding Nothing 54 | where 55 | indexedDecoding = headlessToIndexed decoding 56 | requiredLength = decLength indexedDecoding 57 | 58 | indexedPipe :: Monad m 59 | => Siphon c 60 | -> Decolonnade (Indexed Headless) c a 61 | -> Pipe c a m (DecolonnadeRowError Headless c) 62 | indexedPipe sd decoding = do 63 | e <- consumeGeneral 0 sd mkParseError 64 | case e of 65 | Left err -> return err 66 | Right (firstRow, mleftovers) -> 67 | let req = maxIndex decoding 68 | vlen = Vector.length firstRow 69 | in if vlen < req 70 | then return (DecolonnadeRowError 0 (RowErrorMinSize req vlen)) 71 | else case uncheckedRun decoding firstRow of 72 | Left cellErr -> return $ DecolonnadeRowError 0 $ RowErrorDecode cellErr 73 | Right a -> do 74 | yield a 75 | uncheckedPipe vlen 1 sd decoding mleftovers 76 | 77 | 78 | headedPipe :: (Monad m, Eq c) 79 | => Siphon c 80 | -> Decolonnade Headed c a 81 | -> Pipe c a m (DecolonnadeRowError Headed c) 82 | headedPipe sd decoding = do 83 | e <- consumeGeneral 0 sd mkParseError 84 | case e of 85 | Left err -> return err 86 | Right (headers, mleftovers) -> 87 | case headedToIndexed headers decoding of 88 | Left headingErrs -> return (DecolonnadeRowError 0 (RowErrorHeading headingErrs)) 89 | Right indexedDecoding -> 90 | let requiredLength = Vector.length headers 91 | in uncheckedPipe requiredLength 1 sd indexedDecoding mleftovers 92 | 93 | 94 | uncheckedPipe :: Monad m 95 | => Int -- ^ expected length of each row 96 | -> Int -- ^ index of first row, usually zero or one 97 | -> Siphon c 98 | -> Decolonnade (Indexed f) c a 99 | -> Maybe c 100 | -> Pipe c a m (DecolonnadeRowError f c) 101 | uncheckedPipe requiredLength ix sd d mleftovers = 102 | pipeGeneral ix sd mkParseError checkedRunWithRow mleftovers 103 | where 104 | checkedRunWithRow rowIx v = 105 | let vlen = Vector.length v in 106 | if vlen /= requiredLength 107 | then Left $ DecolonnadeRowError rowIx 108 | $ RowErrorSize requiredLength vlen 109 | else uncheckedRunWithRow rowIx d v 110 | 111 | consumeGeneral :: Monad m 112 | => Int 113 | -> Siphon c 114 | -> (Int -> [String] -> String -> e) 115 | -> Consumer' c m (Either e (Vector c, Maybe c)) 116 | consumeGeneral ix (Siphon _ _ parse isNull) wrapParseError = do 117 | c <- awaitSkip isNull 118 | handleResult (parse c) 119 | where 120 | go k = do 121 | c <- awaitSkip isNull 122 | handleResult (k c) 123 | handleResult r = case r of 124 | Atto.Fail _ ctxs msg -> return $ Left 125 | $ wrapParseError ix ctxs msg 126 | Atto.Done c v -> 127 | let mcontent = if isNull c 128 | then Nothing 129 | else Just c 130 | in return (Right (v,mcontent)) 131 | Atto.Partial k -> go k 132 | 133 | pipeGeneral :: Monad m 134 | => Int -- ^ index of first row, usually zero or one 135 | -> Siphon c 136 | -> (Int -> [String] -> String -> e) 137 | -> (Int -> Vector c -> Either e a) 138 | -> Maybe c -- ^ leftovers that should be handled first 139 | -> Pipe c a m e 140 | pipeGeneral initIx (Siphon _ _ parse isNull) wrapParseError decodeRow mleftovers = 141 | case mleftovers of 142 | Nothing -> go1 initIx 143 | Just leftovers -> handleResult initIx (parse leftovers) 144 | where 145 | go1 !ix = do 146 | c1 <- awaitSkip isNull 147 | handleResult ix (parse c1) 148 | go2 !ix c1 = handleResult ix (parse c1) 149 | go3 !ix k = do 150 | c1 <- awaitSkip isNull 151 | handleResult ix (k c1) 152 | handleResult !ix r = case r of 153 | Atto.Fail _ ctxs msg -> return $ wrapParseError ix ctxs msg 154 | Atto.Done c1 v -> do 155 | case decodeRow ix v of 156 | Left err -> return err 157 | Right r -> do 158 | yield r 159 | let ixNext = ix + 1 160 | if isNull c1 then go1 ixNext else go2 ixNext c1 161 | Atto.Partial k -> go3 ix k 162 | 163 | awaitSkip :: Monad m 164 | => (a -> Bool) 165 | -> Consumer' a m a 166 | awaitSkip f = go where 167 | go = do 168 | a <- await 169 | if f a then go else return a 170 | 171 | -- | Converts the content type of a 'Decolonnade'. The @'Contravariant' f@ 172 | -- constraint means that @f@ can be 'Headless' but not 'Headed'. 173 | contramapContent :: forall c1 c2 f a. Contravariant f => (c2 -> c1) -> Decolonnade f c1 a -> Decolonnade f c2 a 174 | contramapContent f = go 175 | where 176 | go :: forall b. Decolonnade f c1 b -> Decolonnade f c2 b 177 | go (DecolonnadePure x) = DecolonnadePure x 178 | go (DecolonnadeAp h decode apNext) = 179 | DecolonnadeAp (contramap f h) (decode . f) (go apNext) 180 | 181 | headless :: (content -> Either String a) -> Decolonnade Headless content a 182 | headless f = DecolonnadeAp Headless f (DecolonnadePure id) 183 | 184 | headed :: content -> (content -> Either String a) -> Decolonnade Headed content a 185 | headed h f = DecolonnadeAp (Headed h) f (DecolonnadePure id) 186 | 187 | indexed :: Int -> (content -> Either String a) -> Decolonnade (Indexed Headless) content a 188 | indexed ix f = DecolonnadeAp (Indexed ix Headless) f (DecolonnadePure id) 189 | 190 | maxIndex :: forall f c a. Decolonnade (Indexed f) c a -> Int 191 | maxIndex = go 0 where 192 | go :: forall b. Int -> Decolonnade (Indexed f) c b -> Int 193 | go !ix (DecolonnadePure _) = ix 194 | go !ix1 (DecolonnadeAp (Indexed ix2 _) decode apNext) = 195 | go (max ix1 ix2) apNext 196 | 197 | -- | This function uses 'unsafeIndex' to access 198 | -- elements of the 'Vector'. 199 | uncheckedRunWithRow :: 200 | Int 201 | -> Decolonnade (Indexed f) content a 202 | -> Vector content 203 | -> Either (DecolonnadeRowError f content) a 204 | uncheckedRunWithRow i d v = mapLeft (DecolonnadeRowError i . RowErrorDecode) (uncheckedRun d v) 205 | 206 | -- | This function does not check to make sure that the indicies in 207 | -- the 'Decolonnade' are in the 'Vector'. 208 | uncheckedRun :: forall content a f. 209 | Decolonnade (Indexed f) content a 210 | -> Vector content 211 | -> Either (DecolonnadeCellErrors f content) a 212 | uncheckedRun dc v = getEitherWrap (go dc) 213 | where 214 | go :: forall b. 215 | Decolonnade (Indexed f) content b 216 | -> EitherWrap (DecolonnadeCellErrors f content) b 217 | go (DecolonnadePure b) = EitherWrap (Right b) 218 | go (DecolonnadeAp ixed@(Indexed ix h) decode apNext) = 219 | let rnext = go apNext 220 | content = Vector.unsafeIndex v ix 221 | rcurrent = mapLeft (DecolonnadeCellErrors . Vector.singleton . DecolonnadeCellError content ixed) (decode content) 222 | in rnext <*> (EitherWrap rcurrent) 223 | 224 | headlessToIndexed :: forall c a. 225 | Decolonnade Headless c a -> Decolonnade (Indexed Headless) c a 226 | headlessToIndexed = go 0 where 227 | go :: forall b. Int -> Decolonnade Headless c b -> Decolonnade (Indexed Headless) c b 228 | go !ix (DecolonnadePure a) = DecolonnadePure a 229 | go !ix (DecolonnadeAp Headless decode apNext) = 230 | DecolonnadeAp (Indexed ix Headless) decode (go (ix + 1) apNext) 231 | 232 | decLength :: forall f c a. Decolonnade f c a -> Int 233 | decLength = go 0 where 234 | go :: forall b. Int -> Decolonnade f c b -> Int 235 | go !a (DecolonnadePure _) = a 236 | go !a (DecolonnadeAp _ _ apNext) = go (a + 1) apNext 237 | 238 | -- | Maps over a 'Decolonnade' that expects headers, converting these 239 | -- expected headers into the indices of the columns that they 240 | -- correspond to. 241 | headedToIndexed :: forall content a. Eq content 242 | => Vector content -- ^ Headers in the source document 243 | -> Decolonnade Headed content a -- ^ Decolonnade that contains expected headers 244 | -> Either (HeadingErrors content) (Decolonnade (Indexed Headed) content a) 245 | headedToIndexed v = getEitherWrap . go 246 | where 247 | go :: forall b. Eq content 248 | => Decolonnade Headed content b 249 | -> EitherWrap (HeadingErrors content) (Decolonnade (Indexed Headed) content b) 250 | go (DecolonnadePure b) = EitherWrap (Right (DecolonnadePure b)) 251 | go (DecolonnadeAp hd@(Headed h) decode apNext) = 252 | let rnext = go apNext 253 | ixs = Vector.elemIndices h v 254 | ixsLen = Vector.length ixs 255 | rcurrent 256 | | ixsLen == 1 = Right (Vector.unsafeIndex ixs 0) 257 | | ixsLen == 0 = Left (HeadingErrors (Vector.singleton h) Vector.empty) 258 | | otherwise = Left (HeadingErrors Vector.empty (Vector.singleton (h,ixsLen))) 259 | in (\ix ap -> DecolonnadeAp (Indexed ix hd) decode ap) 260 | <$> EitherWrap rcurrent 261 | <*> rnext 262 | 263 | -- | This adds one to the index because text editors consider 264 | -- line number to be one-based, not zero-based. 265 | prettyError :: (c -> String) -> DecolonnadeRowError f c -> String 266 | prettyError toStr (DecolonnadeRowError ix e) = unlines 267 | $ ("Decolonnade error on line " ++ show (ix + 1) ++ " of file.") 268 | : ("Error Category: " ++ descr) 269 | : map (" " ++) errDescrs 270 | where (descr,errDescrs) = prettyRowError toStr e 271 | 272 | prettyRowError :: (content -> String) -> RowError f content -> (String, [String]) 273 | prettyRowError toStr x = case x of 274 | RowErrorParse err -> (,) "CSV Parsing" 275 | [ "The line could not be parsed into cells correctly." 276 | , "Original parser error: " ++ err 277 | ] 278 | RowErrorSize reqLen actualLen -> (,) "Row Length" 279 | [ "Expected the row to have exactly " ++ show reqLen ++ " cells." 280 | , "The row only has " ++ show actualLen ++ " cells." 281 | ] 282 | RowErrorMinSize reqLen actualLen -> (,) "Row Min Length" 283 | [ "Expected the row to have at least " ++ show reqLen ++ " cells." 284 | , "The row only has " ++ show actualLen ++ " cells." 285 | ] 286 | RowErrorMalformed enc -> (,) "Text Decolonnade" 287 | [ "Tried to decode the input as " ++ enc ++ " text" 288 | , "There is a mistake in the encoding of the text." 289 | ] 290 | RowErrorHeading errs -> (,) "Header" (prettyHeadingErrors toStr errs) 291 | RowErrorDecode errs -> (,) "Cell Decolonnade" (prettyCellErrors toStr errs) 292 | 293 | prettyCellErrors :: (c -> String) -> DecolonnadeCellErrors f c -> [String] 294 | prettyCellErrors toStr (DecolonnadeCellErrors errs) = drop 1 $ 295 | flip concatMap errs $ \(DecolonnadeCellError content (Indexed ix _) msg) -> 296 | let str = toStr content in 297 | [ "-----------" 298 | , "Column " ++ columnNumToLetters ix 299 | , "Original parse error: " ++ msg 300 | , "Cell Content Length: " ++ show (Prelude.length str) 301 | , "Cell Content: " ++ if null str 302 | then "[empty cell]" 303 | else str 304 | ] 305 | 306 | prettyHeadingErrors :: (c -> String) -> HeadingErrors c -> [String] 307 | prettyHeadingErrors conv (HeadingErrors missing duplicates) = concat 308 | [ concatMap (\h -> ["The header " ++ conv h ++ " was missing."]) missing 309 | , concatMap (\(h,n) -> ["The header " ++ conv h ++ " occurred " ++ show n ++ " times."]) duplicates 310 | ] 311 | 312 | columnNumToLetters :: Int -> String 313 | columnNumToLetters i 314 | | i >= 0 && i < 25 = [chr (i + 65)] 315 | | otherwise = "Beyond Z. Fix this." 316 | 317 | 318 | newtype EitherWrap a b = EitherWrap 319 | { getEitherWrap :: Either a b 320 | } deriving (Functor) 321 | 322 | instance Monoid a => Applicative (EitherWrap a) where 323 | pure = EitherWrap . Right 324 | EitherWrap (Left a1) <*> EitherWrap (Left a2) = EitherWrap (Left (mappend a1 a2)) 325 | EitherWrap (Left a1) <*> EitherWrap (Right _) = EitherWrap (Left a1) 326 | EitherWrap (Right _) <*> EitherWrap (Left a2) = EitherWrap (Left a2) 327 | EitherWrap (Right f) <*> EitherWrap (Right b) = EitherWrap (Right (f b)) 328 | 329 | mapLeft :: (a -> b) -> Either a c -> Either b c 330 | mapLeft _ (Right a) = Right a 331 | mapLeft f (Left a) = Left (f a) 332 | 333 | 334 | 335 | 336 | 337 | -------------------------------------------------------------------------------- /siphon/src/Siphon/Encoding.hs: -------------------------------------------------------------------------------- 1 | module Siphon.Encoding where 2 | 3 | import Siphon.Types 4 | import Colonnade (Colonnade,Headed) 5 | import Pipes (Pipe,yield) 6 | import qualified Pipes.Prelude as Pipes 7 | import qualified Colonnade.Encode as E 8 | 9 | row :: Siphon c -> Colonnade f a c -> a -> c 10 | row (Siphon escape intercalate _ _) e = 11 | intercalate . E.row escape e 12 | 13 | header :: Siphon c -> Colonnade Headed a c -> c 14 | header (Siphon escape intercalate _ _) e = 15 | intercalate (E.header escape e) 16 | 17 | pipe :: Monad m 18 | => Siphon c 19 | -> Colonnade f a c 20 | -> Pipe a c m x 21 | pipe siphon encoding = Pipes.map (row siphon encoding) 22 | 23 | headedPipe :: Monad m 24 | => Siphon c 25 | -> Colonnade Headed a c 26 | -> Pipe a c m x 27 | headedPipe siphon encoding = do 28 | yield (header siphon encoding) 29 | pipe siphon encoding 30 | 31 | -------------------------------------------------------------------------------- /siphon/src/Siphon/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | -- | A CSV parser. The parser defined here is RFC 4180 compliant, with 4 | -- the following extensions: 5 | -- 6 | -- * Empty lines are ignored. 7 | -- 8 | -- * Non-escaped fields may contain any characters except 9 | -- double-quotes, commas, carriage returns, and newlines. 10 | -- 11 | -- * Escaped fields may contain any characters (but double-quotes 12 | -- need to be escaped). 13 | -- 14 | -- The functions in this module can be used to implement e.g. a 15 | -- resumable parser that is fed input incrementally. 16 | module Siphon.Internal where 17 | 18 | import Siphon.Types 19 | 20 | import Data.ByteString.Builder (toLazyByteString,byteString) 21 | import qualified Data.ByteString.Char8 as BC8 22 | import Control.Applicative (optional) 23 | import Data.Attoparsec.ByteString.Char8 (char, endOfInput, string) 24 | import qualified Data.Attoparsec.ByteString as A 25 | import qualified Data.Attoparsec.Lazy as AL 26 | import qualified Data.Attoparsec.Zepto as Z 27 | import qualified Data.ByteString as S 28 | import qualified Data.ByteString.Unsafe as S 29 | import qualified Data.Vector as V 30 | import qualified Data.ByteString as B 31 | import qualified Data.ByteString.Lazy as LByteString 32 | import qualified Data.ByteString.Builder as Builder 33 | import qualified Data.Text as T 34 | import Data.Word (Word8) 35 | import Data.Vector (Vector) 36 | import Data.ByteString (ByteString) 37 | import Data.Coerce (coerce) 38 | import Siphon.Types 39 | 40 | import Control.Applicative 41 | import Data.Monoid 42 | 43 | byteStringChar8 :: Siphon ByteString 44 | byteStringChar8 = Siphon 45 | escape 46 | encodeRow 47 | (A.parse (row comma)) 48 | B.null 49 | 50 | encodeRow :: Vector (Escaped ByteString) -> ByteString 51 | encodeRow = id 52 | . flip B.append (B.singleton newline) 53 | . B.intercalate (B.singleton comma) 54 | . V.toList 55 | . coerce 56 | 57 | escape :: ByteString -> Escaped ByteString 58 | escape t = case B.find (\c -> c == newline || c == cr || c == comma || c == doubleQuote) t of 59 | Nothing -> Escaped t 60 | Just _ -> escapeAlways t 61 | 62 | -- | This implementation is definitely suboptimal. 63 | -- A better option (which would waste a little space 64 | -- but would be much faster) would be to build the 65 | -- new bytestring by writing to a buffer directly. 66 | escapeAlways :: ByteString -> Escaped ByteString 67 | escapeAlways t = Escaped $ LByteString.toStrict $ Builder.toLazyByteString $ 68 | Builder.word8 doubleQuote 69 | <> B.foldl 70 | (\ acc b -> acc <> if b == doubleQuote 71 | then Builder.byteString 72 | (B.pack [doubleQuote,doubleQuote]) 73 | else Builder.word8 b) 74 | mempty 75 | t 76 | <> Builder.word8 doubleQuote 77 | 78 | -- | Specialized version of 'sepBy1'' which is faster due to not 79 | -- accepting an arbitrary separator. 80 | sepByDelim1' :: AL.Parser a 81 | -> Word8 -- ^ Field delimiter 82 | -> AL.Parser [a] 83 | sepByDelim1' p !delim = liftM2' (:) p loop 84 | where 85 | loop = do 86 | mb <- A.peekWord8 87 | case mb of 88 | Just b | b == delim -> liftM2' (:) (A.anyWord8 *> p) loop 89 | _ -> pure [] 90 | {-# INLINE sepByDelim1' #-} 91 | 92 | -- | Specialized version of 'sepBy1'' which is faster due to not 93 | -- accepting an arbitrary separator. 94 | sepByEndOfLine1' :: AL.Parser a 95 | -> AL.Parser [a] 96 | sepByEndOfLine1' p = liftM2' (:) p loop 97 | where 98 | loop = do 99 | mb <- A.peekWord8 100 | case mb of 101 | Just b | b == cr -> 102 | liftM2' (:) (A.anyWord8 *> A.word8 newline *> p) loop 103 | | b == newline -> 104 | liftM2' (:) (A.anyWord8 *> p) loop 105 | _ -> pure [] 106 | {-# INLINE sepByEndOfLine1' #-} 107 | 108 | -- | Parse a record, not including the terminating line separator. The 109 | -- terminating line separate is not included as the last record in a 110 | -- CSV file is allowed to not have a terminating line separator. You 111 | -- most likely want to use the 'endOfLine' parser in combination with 112 | -- this parser. 113 | row :: Word8 -- ^ Field delimiter 114 | -> AL.Parser (Vector ByteString) 115 | row !delim = rowNoNewline delim <* endOfLine 116 | {-# INLINE row #-} 117 | 118 | rowNoNewline :: Word8 -- ^ Field delimiter 119 | -> AL.Parser (Vector ByteString) 120 | rowNoNewline !delim = V.fromList <$!> field delim `sepByDelim1'` delim 121 | {-# INLINE rowNoNewline #-} 122 | 123 | removeBlankLines :: [Vector ByteString] -> [Vector ByteString] 124 | removeBlankLines = filter (not . blankLine) 125 | 126 | -- | Parse a field. The field may be in either the escaped or 127 | -- non-escaped format. The return value is unescaped. 128 | field :: Word8 -> AL.Parser ByteString 129 | field !delim = do 130 | mb <- A.peekWord8 131 | -- We purposely don't use <|> as we want to commit to the first 132 | -- choice if we see a double quote. 133 | case mb of 134 | Just b | b == doubleQuote -> escapedField 135 | _ -> unescapedField delim 136 | {-# INLINE field #-} 137 | 138 | escapedField :: AL.Parser S.ByteString 139 | escapedField = do 140 | _ <- dquote 141 | -- The scan state is 'True' if the previous character was a double 142 | -- quote. We need to drop a trailing double quote left by scan. 143 | s <- S.init <$> (A.scan False $ \s c -> if c == doubleQuote 144 | then Just (not s) 145 | else if s then Nothing 146 | else Just False) 147 | if doubleQuote `S.elem` s 148 | then case Z.parse unescape s of 149 | Right r -> return r 150 | Left err -> fail err 151 | else return s 152 | 153 | unescapedField :: Word8 -> AL.Parser S.ByteString 154 | unescapedField !delim = A.takeWhile (\ c -> c /= doubleQuote && 155 | c /= newline && 156 | c /= delim && 157 | c /= cr) 158 | 159 | dquote :: AL.Parser Char 160 | dquote = char '"' 161 | 162 | -- | This could be improved. We could avoid the builder and just 163 | -- write to a buffer directly. 164 | unescape :: Z.Parser S.ByteString 165 | unescape = (LByteString.toStrict . toLazyByteString) <$!> go mempty where 166 | go acc = do 167 | h <- Z.takeWhile (/= doubleQuote) 168 | let rest = do 169 | start <- Z.take 2 170 | if (S.unsafeHead start == doubleQuote && 171 | S.unsafeIndex start 1 == doubleQuote) 172 | then go (acc `mappend` byteString h `mappend` byteString (BC8.singleton '"')) 173 | else fail "invalid CSV escape sequence" 174 | done <- Z.atEnd 175 | if done 176 | then return (acc `mappend` byteString h) 177 | else rest 178 | 179 | -- | A strict version of 'Data.Functor.<$>' for monads. 180 | (<$!>) :: Monad m => (a -> b) -> m a -> m b 181 | f <$!> m = do 182 | a <- m 183 | return $! f a 184 | {-# INLINE (<$!>) #-} 185 | 186 | infixl 4 <$!> 187 | 188 | -- | Is this an empty record (i.e. a blank line)? 189 | blankLine :: V.Vector B.ByteString -> Bool 190 | blankLine v = V.length v == 1 && (B.null (V.head v)) 191 | 192 | -- | A version of 'liftM2' that is strict in the result of its first 193 | -- action. 194 | liftM2' :: (Monad m) => (a -> b -> c) -> m a -> m b -> m c 195 | liftM2' f a b = do 196 | !x <- a 197 | y <- b 198 | return (f x y) 199 | {-# INLINE liftM2' #-} 200 | 201 | 202 | -- | Match either a single newline character @\'\\n\'@, or a carriage 203 | -- return followed by a newline character @\"\\r\\n\"@, or a single 204 | -- carriage return @\'\\r\'@. 205 | endOfLine :: A.Parser () 206 | endOfLine = (A.word8 newline *> return ()) <|> (string (BC8.pack "\r\n") *> return ()) <|> (A.word8 cr *> return ()) 207 | {-# INLINE endOfLine #-} 208 | 209 | doubleQuote, newline, cr, comma :: Word8 210 | doubleQuote = 34 211 | newline = 10 212 | cr = 13 213 | comma = 44 214 | 215 | -------------------------------------------------------------------------------- /siphon/src/Siphon/Internal/Text.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | module Siphon.Internal.Text where 4 | 5 | import Siphon.Types 6 | 7 | import Control.Applicative (optional) 8 | import Data.Attoparsec.Text (char, endOfInput, string) 9 | import qualified Data.Attoparsec.Text as A 10 | import qualified Data.Attoparsec.Text.Lazy as AL 11 | import qualified Data.Attoparsec.Zepto as Z 12 | import qualified Data.Text as T 13 | import qualified Data.Text as Text 14 | import qualified Data.Vector as V 15 | import qualified Data.Text.Lazy as LText 16 | import qualified Data.Text.Lazy.Builder as Builder 17 | import Data.Text.Lazy.Builder (Builder) 18 | import Data.Word (Word8) 19 | import Data.Vector (Vector) 20 | import Data.Text (Text) 21 | import Data.Coerce (coerce) 22 | import Siphon.Types 23 | 24 | import Control.Applicative 25 | import Data.Monoid 26 | 27 | text :: Siphon Text 28 | text = Siphon 29 | escape 30 | encodeRow 31 | (A.parse (row comma)) 32 | Text.null 33 | 34 | encodeRow :: Vector (Escaped Text) -> Text 35 | encodeRow = id 36 | . flip Text.append (Text.singleton newline) 37 | . Text.intercalate (Text.singleton comma) 38 | . V.toList 39 | . coerce 40 | 41 | escape :: Text -> Escaped Text 42 | escape t = case Text.find (\c -> c == newline || c == cr || c == comma || c == doubleQuote) t of 43 | Nothing -> Escaped t 44 | Just _ -> escapeAlways t 45 | 46 | -- | This implementation is definitely suboptimal. 47 | -- A better option (which would waste a little space 48 | -- but would be much faster) would be to build the 49 | -- new text by writing to a buffer directly. 50 | escapeAlways :: Text -> Escaped Text 51 | escapeAlways t = Escaped $ Text.concat 52 | [ textDoubleQuote 53 | , Text.replace textDoubleQuote (Text.pack [doubleQuote,doubleQuote]) t 54 | , textDoubleQuote 55 | ] 56 | 57 | -- | Specialized version of 'sepBy1'' which is faster due to not 58 | -- accepting an arbitrary separator. 59 | sepByDelim1' :: A.Parser a 60 | -> Char -- ^ Field delimiter 61 | -> A.Parser [a] 62 | sepByDelim1' p !delim = liftM2' (:) p loop 63 | where 64 | loop = do 65 | mb <- A.peekChar 66 | case mb of 67 | Just b | b == delim -> liftM2' (:) (A.anyChar *> p) loop 68 | _ -> pure [] 69 | {-# INLINE sepByDelim1' #-} 70 | 71 | -- | Specialized version of 'sepBy1'' which is faster due to not 72 | -- accepting an arbitrary separator. 73 | sepByEndOfLine1' :: A.Parser a 74 | -> A.Parser [a] 75 | sepByEndOfLine1' p = liftM2' (:) p loop 76 | where 77 | loop = do 78 | mb <- A.peekChar 79 | case mb of 80 | Just b | b == cr -> 81 | liftM2' (:) (A.anyChar *> A.char newline *> p) loop 82 | | b == newline -> 83 | liftM2' (:) (A.anyChar *> p) loop 84 | _ -> pure [] 85 | {-# INLINE sepByEndOfLine1' #-} 86 | 87 | -- | Parse a record, not including the terminating line separator. The 88 | -- terminating line separate is not included as the last record in a 89 | -- CSV file is allowed to not have a terminating line separator. You 90 | -- most likely want to use the 'endOfLine' parser in combination with 91 | -- this parser. 92 | row :: Char -- ^ Field delimiter 93 | -> A.Parser (Vector Text) 94 | row !delim = rowNoNewline delim <* endOfLine 95 | {-# INLINE row #-} 96 | 97 | rowNoNewline :: Char -- ^ Field delimiter 98 | -> A.Parser (Vector Text) 99 | rowNoNewline !delim = V.fromList <$!> field delim `sepByDelim1'` delim 100 | {-# INLINE rowNoNewline #-} 101 | 102 | -- | Parse a field. The field may be in either the escaped or 103 | -- non-escaped format. The return value is unescaped. 104 | field :: Char -> A.Parser Text 105 | field !delim = do 106 | mb <- A.peekChar 107 | -- We purposely don't use <|> as we want to commit to the first 108 | -- choice if we see a double quote. 109 | case mb of 110 | Just b | b == doubleQuote -> escapedField 111 | _ -> unescapedField delim 112 | {-# INLINE field #-} 113 | 114 | escapedField :: A.Parser Text 115 | escapedField = do 116 | _ <- dquote -- This can probably be replaced with anyChar 117 | b <- escapedFieldInner mempty 118 | return (LText.toStrict (Builder.toLazyText b)) 119 | 120 | escapedFieldInner :: Builder -> A.Parser Builder 121 | escapedFieldInner b = do 122 | t <- A.takeTill (== doubleQuote) 123 | _ <- A.anyChar -- this will always be a double quote 124 | c <- A.peekChar' 125 | if c == doubleQuote 126 | then do 127 | _ <- A.anyChar -- this will always be a double quote 128 | escapedFieldInner (b `mappend` Builder.fromText t `mappend` Builder.fromText textDoubleQuote) 129 | else return (b `mappend` Builder.fromText t) 130 | 131 | unescapedField :: Char -> A.Parser Text 132 | unescapedField !delim = A.takeWhile (\ c -> c /= doubleQuote && 133 | c /= newline && 134 | c /= delim && 135 | c /= cr) 136 | 137 | dquote :: A.Parser Char 138 | dquote = char doubleQuote 139 | 140 | unescape :: A.Parser Text 141 | unescape = (LText.toStrict . Builder.toLazyText) <$!> go mempty where 142 | go acc = do 143 | h <- A.takeWhile (/= doubleQuote) 144 | let rest = do 145 | c0 <- A.anyChar 146 | c1 <- A.anyChar 147 | if (c0 == doubleQuote && c1 == doubleQuote) 148 | then go (acc `mappend` Builder.fromText h `mappend` Builder.fromText textDoubleQuote) 149 | else fail "invalid CSV escape sequence" 150 | done <- A.atEnd 151 | if done 152 | then return (acc `mappend` Builder.fromText h) 153 | else rest 154 | 155 | -- | A strict version of 'Data.Functor.<$>' for monads. 156 | (<$!>) :: Monad m => (a -> b) -> m a -> m b 157 | f <$!> m = do 158 | a <- m 159 | return $! f a 160 | {-# INLINE (<$!>) #-} 161 | 162 | infixl 4 <$!> 163 | 164 | -- | A version of 'liftM2' that is strict in the result of its first 165 | -- action. 166 | liftM2' :: (Monad m) => (a -> b -> c) -> m a -> m b -> m c 167 | liftM2' f a b = do 168 | !x <- a 169 | y <- b 170 | return (f x y) 171 | {-# INLINE liftM2' #-} 172 | 173 | 174 | -- | Match either a single newline character @\'\\n\'@, or a carriage 175 | -- return followed by a newline character @\"\\r\\n\"@, or a single 176 | -- carriage return @\'\\r\'@. 177 | endOfLine :: A.Parser () 178 | endOfLine = (A.char newline *> return ()) <|> (string (Text.pack "\r\n") *> return ()) <|> (A.char cr *> return ()) 179 | {-# INLINE endOfLine #-} 180 | 181 | textDoubleQuote :: Text 182 | textDoubleQuote = Text.singleton doubleQuote 183 | 184 | doubleQuote, newline, cr, comma :: Char 185 | doubleQuote = '\"' 186 | newline = '\n' 187 | cr = '\r' 188 | comma = ',' 189 | 190 | -------------------------------------------------------------------------------- /siphon/src/Siphon/Text.hs: -------------------------------------------------------------------------------- 1 | module Siphon.Text where 2 | 3 | import Siphon.Types 4 | import Data.Text (Text) 5 | import Data.Vector (Vector) 6 | import Data.Coerce (coerce) 7 | import qualified Data.Text as Text 8 | import qualified Data.Vector as Vector 9 | 10 | siphon :: Siphon Text 11 | siphon = Siphon escape encodeRow 12 | (error "siphon: uhoent") (error "siphon: uheokj") 13 | 14 | encodeRow :: Vector (Escaped Text) -> Text 15 | encodeRow = id 16 | . Text.intercalate (Text.singleton ',') 17 | . Vector.toList 18 | . coerce 19 | 20 | escape :: Text -> Escaped Text 21 | escape t = case Text.find (\c -> c == '\n' || c == ',' || c == '"') t of 22 | Nothing -> Escaped t 23 | Just _ -> escapeAlways t 24 | 25 | escapeAlways :: Text -> Escaped Text 26 | escapeAlways t = Escaped $ Text.concat 27 | [ Text.singleton '"' 28 | , Text.replace (Text.pack "\"") (Text.pack "\"\"") t 29 | , Text.singleton '"' 30 | ] 31 | 32 | 33 | 34 | -------------------------------------------------------------------------------- /siphon/src/Siphon/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | 5 | {-# OPTIONS_GHC -Wall -Werror #-} 6 | 7 | module Siphon.Types 8 | ( Siphon(..) 9 | , Indexed(..) 10 | , SiphonError(..) 11 | , RowError(..) 12 | , CellError(..) 13 | ) where 14 | 15 | import Data.Vector (Vector) 16 | import Control.Exception (Exception) 17 | import Data.Text (Text) 18 | import Data.Functor.Classes (Eq1,Show1,liftEq,liftShowsPrec) 19 | 20 | data CellError = CellError 21 | { cellErrorColumn :: !Int 22 | , cellErrorContent :: !Text 23 | } deriving (Show,Read,Eq) 24 | 25 | newtype Indexed a = Indexed 26 | { indexedIndex :: Int 27 | } deriving (Eq,Ord,Functor,Show,Read) 28 | 29 | instance Show1 Indexed where 30 | liftShowsPrec _ _ p (Indexed i) s = showsPrec p i s 31 | 32 | instance Eq1 Indexed where 33 | liftEq _ (Indexed i) (Indexed j) = i == j 34 | 35 | data SiphonError = SiphonError 36 | { siphonErrorRow :: !Int 37 | , siphonErrorCause :: !RowError 38 | } deriving (Show,Read,Eq) 39 | 40 | instance Exception SiphonError 41 | 42 | data RowError 43 | = RowErrorParse 44 | -- ^ Error occurred parsing the document into cells 45 | | RowErrorDecode !(Vector CellError) 46 | -- ^ Error decoding the content 47 | | RowErrorSize !Int !Int 48 | -- ^ Wrong number of cells in the row 49 | | RowErrorHeaders !(Vector (Vector CellError)) !(Vector Text) !(Vector Int) 50 | -- ^ Three parts: 51 | -- (a) Multiple header cells matched the same expected cell, 52 | -- (b) Headers that were missing, 53 | -- (c) Missing headers that were lambdas. They cannot be 54 | -- shown so instead their positions in the 'Siphon' are given. 55 | | RowErrorHeaderSize !Int !Int 56 | -- ^ Not enough cells in header, expected, actual 57 | | RowErrorMalformed !Int 58 | -- ^ Error decoding unicode content, column number 59 | deriving (Show,Read,Eq) 60 | 61 | -- | This just actually a specialization of the free applicative. 62 | -- Check out @Control.Applicative.Free@ in the @free@ library to 63 | -- learn more about this. The meanings of the fields are documented 64 | -- slightly more in the source code. Unfortunately, haddock does not 65 | -- play nicely with GADTs. 66 | data Siphon f c a where 67 | SiphonPure :: 68 | !a -- function 69 | -> Siphon f c a 70 | SiphonAp :: 71 | !(f c) -- header 72 | -> !(c -> Maybe a) -- decoding function 73 | -> !(Siphon f c (a -> b)) -- next decoding 74 | -> Siphon f c b 75 | 76 | instance Functor (Siphon f c) where 77 | fmap f (SiphonPure a) = SiphonPure (f a) 78 | fmap f (SiphonAp h c apNext) = SiphonAp h c ((f .) <$> apNext) 79 | 80 | instance Applicative (Siphon f c) where 81 | pure = SiphonPure 82 | SiphonPure f <*> y = fmap f y 83 | SiphonAp h c y <*> z = SiphonAp h c (flip <$> y <*> z) 84 | 85 | -------------------------------------------------------------------------------- /siphon/test/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | 5 | module Main (main) where 6 | 7 | import Colonnade (headed,headless,Colonnade,Headed,Headless) 8 | import Control.Exception 9 | import Data.ByteString (ByteString) 10 | import Data.Char (ord) 11 | import Data.Either.Combinators 12 | import Data.Functor.Contravariant (contramap) 13 | import Data.Functor.Contravariant.Divisible (divided,conquered) 14 | import Data.Functor.Identity 15 | import Data.Profunctor (lmap) 16 | import Data.Text (Text) 17 | import Data.Word (Word8) 18 | import Debug.Trace 19 | import GHC.Generics (Generic) 20 | import Siphon.Types 21 | import Streaming (Stream,Of(..)) 22 | import Test.Framework (defaultMain, testGroup, Test) 23 | import Test.Framework.Providers.HUnit (testCase) 24 | import Test.Framework.Providers.QuickCheck2 (testProperty) 25 | import Test.HUnit (Assertion,(@?=)) 26 | import Test.QuickCheck (Gen, Arbitrary(..), choose, elements, Property) 27 | import Test.QuickCheck.Property (Result, succeeded, exception) 28 | 29 | import qualified Data.Text as Text 30 | import qualified Data.ByteString.Builder as Builder 31 | import qualified Data.ByteString.Lazy as LByteString 32 | import qualified Data.ByteString as ByteString 33 | import qualified Data.ByteString.Char8 as BC8 34 | import qualified Data.ByteString as B 35 | import qualified Data.Vector as Vector 36 | import qualified Colonnade as Colonnade 37 | import qualified Siphon as S 38 | import qualified Streaming.Prelude as SMP 39 | import qualified Data.Text.Lazy as LText 40 | import qualified Data.Text.Lazy.Builder as TBuilder 41 | import qualified Data.Text.Lazy.Builder.Int as TBuilder 42 | 43 | main :: IO () 44 | main = defaultMain tests 45 | 46 | tests :: [Test] 47 | tests = 48 | [ testGroup "ByteString encode/decode" 49 | [ testCase "Headed Encoding (int,char,bool)" 50 | $ runTestScenario [(4,intToWord8 (ord 'c'),False)] 51 | S.encodeCsvStreamUtf8 52 | encodingB 53 | $ ByteString.concat 54 | [ "number,letter,boolean\n" 55 | , "4,c,false\n" 56 | ] 57 | , testCase "Headed Encoding (int,char,bool) monoidal building" 58 | $ runTestScenario [(4,'c',False)] 59 | S.encodeCsvStreamUtf8 60 | encodingC 61 | $ ByteString.concat 62 | [ "boolean,letter\n" 63 | , "false,c\n" 64 | ] 65 | , testCase "Headed Encoding (escaped characters)" 66 | $ runTestScenario ["bob","there,be,commas","the \" quote"] 67 | S.encodeCsvStreamUtf8 68 | encodingF 69 | $ ByteString.concat 70 | [ "name\n" 71 | , "bob\n" 72 | , "\"there,be,commas\"\n" 73 | , "\"the \"\" quote\"\n" 74 | ] 75 | , testCase "Headed Decoding (int,char,bool)" 76 | $ ( runIdentity . SMP.toList ) 77 | ( S.decodeCsvUtf8 decodingB 78 | ( mapM_ (SMP.yield . BC8.singleton) $ concat 79 | [ "number,letter,boolean\n" 80 | , "244,z,true\n" 81 | ] 82 | ) 83 | ) @?= ([(244,intToWord8 (ord 'z'),True)] :> Nothing) 84 | , testCase "Headed Decoding (geolite)" 85 | $ ( runIdentity . SMP.toList ) 86 | ( S.decodeCsvUtf8 decodingGeolite 87 | ( SMP.yield $ BC8.pack $ concat 88 | [ "network,autonomous_system_number,autonomous_system_organization\n" 89 | , "1,z,y\n" 90 | ] 91 | ) 92 | ) @?= ([(1,intToWord8 (ord 'z'),intToWord8 (ord 'y'))] :> Nothing) 93 | , testCase "Headed Decoding (escaped characters, one big chunk)" 94 | $ ( runIdentity . SMP.toList ) 95 | ( S.decodeCsvUtf8 decodingF 96 | ( SMP.yield $ BC8.pack $ concat 97 | [ "name\n" 98 | , "drew\n" 99 | , "\"martin, drew\"\n" 100 | ] 101 | ) 102 | ) @?= (["drew","martin, drew"] :> Nothing) 103 | , testCase "Headed Decoding (escaped characters, character per chunk)" 104 | $ ( runIdentity . SMP.toList ) 105 | ( S.decodeCsvUtf8 decodingF 106 | ( mapM_ (SMP.yield . BC8.singleton) $ concat 107 | [ "name\n" 108 | , "drew\n" 109 | , "\"martin, drew\"\n" 110 | ] 111 | ) 112 | ) @?= (["drew","martin, drew"] :> Nothing) 113 | , testCase "Headed Decoding (escaped characters, character per chunk, CRLF)" 114 | $ ( runIdentity . SMP.toList ) 115 | ( S.decodeCsvUtf8 decodingF 116 | ( mapM_ (SMP.yield . BC8.singleton) $ concat 117 | [ "name\r\n" 118 | , "drew\r\n" 119 | , "\"martin, drew\"\r\n" 120 | ] 121 | ) 122 | ) @?= (["drew","martin, drew"] :> Nothing) 123 | , testCase "headedToIndexed" $ 124 | let actual = S.headedToIndexed id (Vector.fromList ["letter","boolean","number"]) decodingG 125 | in case actual of 126 | Left e -> fail "headedToIndexed failed" 127 | Right actualInner -> 128 | let expected = SiphonAp (Indexed 2 :: Indexed Text) (\_ -> Nothing) 129 | $ SiphonAp (Indexed 0 :: Indexed Text) (\_ -> Nothing) 130 | $ SiphonAp (Indexed 1 :: Indexed Text) (\_ -> Nothing) 131 | $ SiphonPure (\_ _ _ -> ()) 132 | in case S.eqSiphonHeaders actualInner expected of 133 | True -> pure () 134 | False -> fail $ 135 | "Expected " ++ 136 | S.showSiphonHeaders expected ++ 137 | " but got " ++ 138 | S.showSiphonHeaders actualInner 139 | , testCase "Indexed Decoding (int,char,bool)" 140 | $ ( runIdentity . SMP.toList ) 141 | ( S.decodeIndexedCsvUtf8 3 indexedDecodingB 142 | ( mapM_ (SMP.yield . BC8.singleton) $ concat 143 | [ "244,z,true\n" 144 | ] 145 | ) 146 | ) @?= ([(244,intToWord8 (ord 'z'),True)] :> Nothing) 147 | , testProperty "Headed Isomorphism (int,char,bool)" 148 | $ propIsoStream BC8.unpack 149 | (S.decodeCsvUtf8 decodingB) 150 | (S.encodeCsvStreamUtf8 encodingB) 151 | ] 152 | ] 153 | 154 | intToWord8 :: Int -> Word8 155 | intToWord8 = fromIntegral 156 | 157 | data Foo = FooA | FooB | FooC 158 | deriving (Generic,Eq,Ord,Show,Read,Bounded,Enum) 159 | 160 | instance Arbitrary Foo where 161 | arbitrary = elements [minBound..maxBound] 162 | 163 | fooToString :: Foo -> String 164 | fooToString x = case x of 165 | FooA -> "Simple" 166 | FooB -> "With,Escaped\nChars" 167 | FooC -> "More\"Escaped,\"\"Chars" 168 | 169 | encodeFoo :: (String -> c) -> Foo -> c 170 | encodeFoo f = f . fooToString 171 | 172 | fooFromString :: String -> Maybe Foo 173 | fooFromString x = case x of 174 | "Simple" -> Just FooA 175 | "With,Escaped\nChars" -> Just FooB 176 | "More\"Escaped,\"\"Chars" -> Just FooC 177 | _ -> Nothing 178 | 179 | decodeFoo :: (c -> String) -> c -> Maybe Foo 180 | decodeFoo f = fooFromString . f 181 | 182 | decodingA :: Siphon Headless ByteString (Int,Char,Bool) 183 | decodingA = (,,) 184 | <$> S.headless dbInt 185 | <*> S.headless dbChar 186 | <*> S.headless dbBool 187 | 188 | decodingB :: Siphon Headed ByteString (Int,Word8,Bool) 189 | decodingB = (,,) 190 | <$> S.headed "number" dbInt 191 | <*> S.headed "letter" dbWord8 192 | <*> S.headed "boolean" dbBool 193 | 194 | indexedDecodingB :: Siphon Indexed ByteString (Int,Word8,Bool) 195 | indexedDecodingB = (,,) 196 | <$> S.indexed 0 dbInt 197 | <*> S.indexed 1 dbWord8 198 | <*> S.indexed 2 dbBool 199 | 200 | decodingG :: Siphon Headed Text () 201 | decodingG = 202 | S.headed "number" (\_ -> Nothing) 203 | <* S.headed "letter" (\_ -> Nothing) 204 | <* S.headed "boolean" (\_ -> Nothing) 205 | 206 | decodingF :: Siphon Headed ByteString ByteString 207 | decodingF = S.headed "name" Just 208 | 209 | decodingGeolite :: Siphon Headed ByteString (Int,Word8,Word8) 210 | decodingGeolite = (,,) 211 | <$> S.headed "network" dbInt 212 | <*> S.headed "autonomous_system_number" dbWord8 213 | <*> S.headed "autonomous_system_organization" dbWord8 214 | 215 | 216 | encodingA :: Colonnade Headless (Int,Char,Bool) ByteString 217 | encodingA = mconcat 218 | [ lmap fst3 (headless ebInt) 219 | , lmap snd3 (headless ebChar) 220 | , lmap thd3 (headless ebBool) 221 | ] 222 | 223 | encodingW :: Colonnade Headless (Int,Char,Bool) Text 224 | encodingW = mconcat 225 | [ lmap fst3 (headless etInt) 226 | , lmap snd3 (headless etChar) 227 | , lmap thd3 (headless etBool) 228 | ] 229 | 230 | encodingY :: Colonnade Headless (Foo,Foo,Foo) Text 231 | encodingY = mconcat 232 | [ lmap fst3 (headless $ encodeFoo Text.pack) 233 | , lmap snd3 (headless $ encodeFoo Text.pack) 234 | , lmap thd3 (headless $ encodeFoo Text.pack) 235 | ] 236 | 237 | decodingY :: Siphon Headless Text (Foo,Foo,Foo) 238 | decodingY = (,,) 239 | <$> S.headless (decodeFoo Text.unpack) 240 | <*> S.headless (decodeFoo Text.unpack) 241 | <*> S.headless (decodeFoo Text.unpack) 242 | 243 | encodingF :: Colonnade Headed ByteString ByteString 244 | encodingF = headed "name" id 245 | 246 | encodingB :: Colonnade Headed (Int,Word8,Bool) ByteString 247 | encodingB = mconcat 248 | [ lmap fst3 (headed "number" ebInt) 249 | , lmap snd3 (headed "letter" ebWord8) 250 | , lmap thd3 (headed "boolean" ebBool) 251 | ] 252 | 253 | encodingC :: Colonnade Headed (Int,Char,Bool) ByteString 254 | encodingC = mconcat 255 | [ lmap thd3 $ headed "boolean" ebBool 256 | , lmap snd3 $ headed "letter" ebChar 257 | ] 258 | 259 | tripleToPairs :: (a,b,c) -> (a,(b,(c,()))) 260 | tripleToPairs (a,b,c) = (a,(b,(c,()))) 261 | 262 | propIsoStream :: (Eq a, Show a, Monoid c) 263 | => (c -> String) 264 | -> (Stream (Of c) Identity () -> Stream (Of a) Identity (Maybe SiphonError)) 265 | -> (Stream (Of a) Identity () -> Stream (Of c) Identity ()) 266 | -> [a] 267 | -> Result 268 | propIsoStream toStr decode encode as = 269 | let asNew :> m = runIdentity $ SMP.toList $ decode $ encode $ SMP.each as 270 | in case m of 271 | Nothing -> if as == asNew 272 | then succeeded 273 | else exception ("expected " ++ show as ++ " but got " ++ show asNew) myException 274 | Just err -> 275 | let csv = toStr $ mconcat $ runIdentity $ SMP.toList_ $ encode $ SMP.each as 276 | in exception (S.humanizeSiphonError err ++ "\nGenerated CSV\n" ++ csv) myException 277 | 278 | data MyException = MyException 279 | deriving (Show,Read,Eq) 280 | instance Exception MyException 281 | 282 | myException :: SomeException 283 | myException = SomeException MyException 284 | 285 | runTestScenario :: (Monoid c, Eq c, Show c, Eq a, Show a) 286 | => [a] 287 | -> (Colonnade f a c -> Stream (Of a) Identity () -> Stream (Of c) Identity ()) 288 | -> Colonnade f a c 289 | -> c 290 | -> Assertion 291 | runTestScenario as p e c = 292 | ( mconcat (runIdentity (SMP.toList_ (p e (mapM_ SMP.yield as)))) 293 | ) @?= c 294 | 295 | -- runCustomTestScenario :: (Monoid c, Eq c, Show c) 296 | -- => Siphon c 297 | -- -> (Siphon c -> Colonnade f a c -> Pipe a c Identity ()) 298 | -- -> Colonnade f a c 299 | -- -> a 300 | -- -> c 301 | -- -> Assertion 302 | -- runCustomTestScenario s p e a c = 303 | -- ( mconcat $ Pipes.toList $ 304 | -- Pipes.yield a >-> p s e 305 | -- ) @?= c 306 | 307 | -- testEncodingA :: Assertion 308 | -- testEncodingA = runTestScenario encodingA "4,c,false\n" 309 | 310 | propEncodeDecodeIso :: Eq a => (a -> b) -> (b -> Maybe a) -> a -> Bool 311 | propEncodeDecodeIso f g a = g (f a) == Just a 312 | 313 | propMatching :: Eq b => (a -> b) -> (a -> b) -> a -> Bool 314 | propMatching f g a = f a == g a 315 | 316 | 317 | -- | Take the first item out of a 3 element tuple 318 | fst3 :: (a,b,c) -> a 319 | fst3 (a,b,c) = a 320 | 321 | -- | Take the second item out of a 3 element tuple 322 | snd3 :: (a,b,c) -> b 323 | snd3 (a,b,c) = b 324 | 325 | -- | Take the third item out of a 3 element tuple 326 | thd3 :: (a,b,c) -> c 327 | thd3 (a,b,c) = c 328 | 329 | 330 | dbChar :: ByteString -> Maybe Char 331 | dbChar b = case BC8.length b of 332 | 1 -> Just (BC8.head b) 333 | _ -> Nothing 334 | 335 | dbWord8 :: ByteString -> Maybe Word8 336 | dbWord8 b = case B.length b of 337 | 1 -> Just (B.head b) 338 | _ -> Nothing 339 | 340 | dbInt :: ByteString -> Maybe Int 341 | dbInt b = do 342 | (a,bsRem) <- BC8.readInt b 343 | if ByteString.null bsRem 344 | then Just a 345 | else Nothing 346 | 347 | dbBool :: ByteString -> Maybe Bool 348 | dbBool b 349 | | b == BC8.pack "true" = Just True 350 | | b == BC8.pack "false" = Just False 351 | | otherwise = Nothing 352 | 353 | ebChar :: Char -> ByteString 354 | ebChar = BC8.singleton 355 | 356 | ebWord8 :: Word8 -> ByteString 357 | ebWord8 = B.singleton 358 | 359 | ebInt :: Int -> ByteString 360 | ebInt = LByteString.toStrict 361 | . Builder.toLazyByteString 362 | . Builder.intDec 363 | 364 | ebBool :: Bool -> ByteString 365 | ebBool x = case x of 366 | True -> BC8.pack "true" 367 | False -> BC8.pack "false" 368 | 369 | ebByteString :: ByteString -> ByteString 370 | ebByteString = id 371 | 372 | 373 | etChar :: Char -> Text 374 | etChar = Text.singleton 375 | 376 | etInt :: Int -> Text 377 | etInt = LText.toStrict 378 | . TBuilder.toLazyText 379 | . TBuilder.decimal 380 | 381 | etText :: Text -> Text 382 | etText = id 383 | 384 | etBool :: Bool -> Text 385 | etBool x = case x of 386 | True -> Text.pack "true" 387 | False -> Text.pack "false" 388 | 389 | -------------------------------------------------------------------------------- /yesod-colonnade/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Andrew Martin (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Andrew Martin nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /yesod-colonnade/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /yesod-colonnade/hackage-docs.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | 4 | if [ "$#" -ne 1 ]; then 5 | echo "Usage: scripts/hackage-docs.sh HACKAGE_USER" 6 | exit 1 7 | fi 8 | 9 | user=$1 10 | 11 | cabal_file=$(find . -maxdepth 1 -name "*.cabal" -print -quit) 12 | if [ ! -f "$cabal_file" ]; then 13 | echo "Run this script in the top-level package directory" 14 | exit 1 15 | fi 16 | 17 | pkg=$(awk -F ":[[:space:]]*" 'tolower($1)=="name" { print $2 }' < "$cabal_file") 18 | ver=$(awk -F ":[[:space:]]*" 'tolower($1)=="version" { print $2 }' < "$cabal_file") 19 | 20 | if [ -z "$pkg" ]; then 21 | echo "Unable to determine package name" 22 | exit 1 23 | fi 24 | 25 | if [ -z "$ver" ]; then 26 | echo "Unable to determine package version" 27 | exit 1 28 | fi 29 | 30 | echo "Detected package: $pkg-$ver" 31 | 32 | dir=$(mktemp -d build-docs.XXXXXX) 33 | trap 'rm -r "$dir"' EXIT 34 | 35 | # cabal haddock --hoogle --hyperlink-source --html-location='/package/$pkg-$version/docs' --contents-location='/package/$pkg-$version' 36 | stack haddock 37 | 38 | cp -R .stack-work/dist/x86_64-linux/Cabal-1.22.5.0/doc/html/$pkg/ $dir/$pkg-$ver-docs 39 | # /home/andrew/.stack/snapshots/x86_64-linux/lts-5.17/7.10.3/doc/index.html 40 | 41 | tar cvz -C $dir --format=ustar -f $dir/$pkg-$ver-docs.tar.gz $pkg-$ver-docs 42 | 43 | curl -X PUT \ 44 | -H 'Content-Type: application/x-tar' \ 45 | -H 'Content-Encoding: gzip' \ 46 | -u "$user" \ 47 | --data-binary "@$dir/$pkg-$ver-docs.tar.gz" \ 48 | "https://hackage.haskell.org/package/$pkg-$ver/docs" 49 | -------------------------------------------------------------------------------- /yesod-colonnade/src/Yesod/Colonnade.hs: -------------------------------------------------------------------------------- 1 | -- | Build HTML tables using @yesod@ and @colonnade@. To learn 2 | -- how to use this module, first read the documentation for @colonnade@, 3 | -- and then read the documentation for @blaze-colonnade@. This library 4 | -- and @blaze-colonnade@ are entirely distinct; neither depends on the 5 | -- other. However, the interfaces they expose are very similar, and 6 | -- the explanations provided counterpart are sufficient to understand 7 | -- this library. 8 | module Yesod.Colonnade 9 | ( -- * Build 10 | Cell(..) 11 | , cell 12 | , stringCell 13 | , textCell 14 | , builderCell 15 | , anchorCell 16 | , anchorWidget 17 | -- * Apply 18 | , encodeWidgetTable 19 | , encodeCellTable 20 | , encodeDefinitionTable 21 | , encodeListItems 22 | ) where 23 | 24 | import Yesod.Core 25 | import Yesod.Core.Types (Body(..),GWData(..),WidgetFor(..),wdRef) 26 | import Colonnade (Colonnade,Headed,Headless) 27 | import Data.Text (Text) 28 | import Control.Monad 29 | import Data.IORef (modifyIORef') 30 | import Data.Monoid 31 | import Data.String (IsString(..)) 32 | import Text.Blaze (Attribute,toValue) 33 | import Data.Foldable 34 | import Yesod.Elements (table_,thead_,tbody_,tr_,td_,th_,ul_,li_,a_) 35 | import Data.Semigroup (Semigroup) 36 | import qualified Data.Semigroup as SG 37 | import qualified Text.Blaze.Html5.Attributes as HA 38 | import qualified Text.Blaze.Html5 as H 39 | import qualified Colonnade.Encode as E 40 | import qualified Data.Text as Text 41 | import qualified Data.Text.Lazy as LText 42 | import qualified Data.Text.Lazy.Builder as TBuilder 43 | 44 | -- | The attributes that will be applied to a @		@ and 45 | -- the HTML content that will go inside it. 46 | data Cell site = Cell 47 | { cellAttrs :: [Attribute] 48 | , cellContents :: !(WidgetFor site ()) 49 | } 50 | 51 | instance IsString (Cell site) where 52 | fromString = stringCell 53 | 54 | instance Semigroup (Cell site) where 55 | Cell a1 c1 <> Cell a2 c2 = Cell (mappend a1 a2) (mappend c1 c2) 56 | instance Monoid (Cell site) where 57 | mempty = Cell mempty mempty 58 | mappend = (SG.<>) 59 | 60 | -- | Create a 'Cell' from a 'Widget' 61 | cell :: WidgetFor site () -> Cell site 62 | cell = Cell mempty 63 | 64 | -- | Create a 'Cell' from a 'String' 65 | stringCell :: String -> Cell site 66 | stringCell = cell . fromString 67 | 68 | -- | Create a 'Cell' from a 'Text' 69 | textCell :: Text -> Cell site 70 | textCell = cell . toWidget . toHtml 71 | 72 | -- | Create a 'Cell' from a text builder 73 | builderCell :: TBuilder.Builder -> Cell site 74 | builderCell = cell . toWidget . toHtml . LText.toStrict . TBuilder.toLazyText 75 | 76 | -- | Create a 'Cell' whose content is hyperlinked by wrapping 77 | -- it in an @\@. 78 | anchorCell :: 79 | (a -> Route site) -- ^ Route that will go in @href@ attribute 80 | -> (a -> WidgetFor site ()) -- ^ Content wrapped by @@ tag 81 | -> a -- ^ Value 82 | -> Cell site 83 | anchorCell getRoute getContent = cell . anchorWidget getRoute getContent 84 | 85 | -- | Create a widget whose content is hyperlinked by wrapping 86 | -- it in an @\@. 87 | anchorWidget :: 88 | (a -> Route site) -- ^ Route that will go in @href@ attribute 89 | -> (a -> WidgetFor site ()) -- ^ Content wrapped by @@ tag 90 | -> a -- ^ Value 91 | -> WidgetFor site () 92 | anchorWidget getRoute getContent a = do 93 | urlRender <- getUrlRender 94 | a_ [HA.href (toValue (urlRender (getRoute a)))] (getContent a) 95 | 96 | -- | This determines the attributes that are added 97 | -- to the individual @li@s by concatenating the header\'s 98 | -- attributes with the data\'s attributes. 99 | encodeListItems :: 100 | (WidgetFor site () -> WidgetFor site ()) 101 | -- ^ Wrapper for items, often @ul@ 102 | -> (WidgetFor site () -> WidgetFor site () -> WidgetFor site ()) 103 | -- ^ Combines header with data 104 | -> Colonnade Headed a (Cell site) 105 | -- ^ How to encode data as a row 106 | -> a 107 | -- ^ The value to display 108 | -> WidgetFor site () 109 | encodeListItems ulWrap combine enc = 110 | ulWrap . E.bothMonadic_ enc 111 | (\(Cell ha hc) (Cell ba bc) -> 112 | li_ (ha <> ba) (combine hc bc) 113 | ) 114 | 115 | -- | A two-column table with the header content displayed in the 116 | -- first column and the data displayed in the second column. Note 117 | -- that the generated HTML table does not have a @thead@. 118 | encodeDefinitionTable :: 119 | [Attribute] 120 | -- ^ Attributes of @table@ element. 121 | -> Colonnade Headed a (Cell site) 122 | -- ^ How to encode data as a row 123 | -> a 124 | -- ^ The value to display 125 | -> WidgetFor site () 126 | encodeDefinitionTable attrs enc a = table_ attrs $ tbody_ [] $ 127 | E.bothMonadic_ enc 128 | (\theKey theValue -> tr_ [] $ do 129 | widgetFromCell td_ theKey 130 | widgetFromCell td_ theValue 131 | ) a 132 | 133 | -- | Encode an html table with attributes on the table cells. 134 | -- If you are using the bootstrap css framework, then you may want 135 | -- to call this with the first argument as: 136 | -- 137 | -- > encodeCellTable (HA.class_ "table table-striped") ... 138 | encodeCellTable :: (Foldable f, E.Headedness h) 139 | => [Attribute] -- ^ Attributes of @table@ element 140 | -> Colonnade h a (Cell site) -- ^ How to encode data as a row 141 | -> f a -- ^ Rows of data 142 | -> WidgetFor site () 143 | encodeCellTable = encodeTable 144 | (E.headednessPure mempty) mempty (const mempty) widgetFromCell 145 | 146 | -- | Encode an html table. 147 | encodeWidgetTable :: (Foldable f, E.Headedness h) 148 | => [Attribute] -- ^ Attributes of @\@ element 149 | -> Colonnade h a (WidgetFor site ()) -- ^ How to encode data as columns 150 | -> f a -- ^ Rows of data 151 | -> WidgetFor site () 152 | encodeWidgetTable = encodeTable 153 | (E.headednessPure mempty) mempty (const mempty) ($ mempty) 154 | 155 | -- | Encode a table. This handles a very general case and 156 | -- is seldom needed by users. One of the arguments provided is 157 | -- used to add attributes to the generated @\@ elements. 158 | encodeTable :: 159 | (Foldable f, E.Headedness h) 160 | => h [Attribute] -- ^ Attributes of @\@ 161 | -> [Attribute] -- ^ Attributes of @\@ element 162 | -> (a -> [Attribute]) -- ^ Attributes of each @\@ element 163 | -> (([Attribute] -> WidgetFor site () -> WidgetFor site ()) -> c -> WidgetFor site ()) -- ^ Wrap content and convert to 'Html' 164 | -> [Attribute] -- ^ Attributes of @\@ element 165 | -> Colonnade h a c -- ^ How to encode data as a row 166 | -> f a -- ^ Collection of data 167 | -> WidgetFor site () 168 | encodeTable theadAttrs tbodyAttrs trAttrs wrapContent tableAttrs colonnade xs = 169 | table_ tableAttrs $ do 170 | for_ E.headednessExtract $ \unhead -> 171 | thead_ (unhead theadAttrs) $ do 172 | E.headerMonadicGeneral_ colonnade (wrapContent th_) 173 | tbody_ tbodyAttrs $ do 174 | forM_ xs $ \x -> do 175 | tr_ (trAttrs x) (E.rowMonadic_ colonnade (wrapContent td_) x) 176 | 177 | widgetFromCell :: 178 | ([Attribute] -> WidgetFor site () -> WidgetFor site ()) 179 | -> Cell site 180 | -> WidgetFor site () 181 | widgetFromCell f (Cell attrs contents) = 182 | f attrs contents 183 | 184 | -------------------------------------------------------------------------------- /yesod-colonnade/yesod-colonnade.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.0 2 | name: yesod-colonnade 3 | version: 1.3.0.2 4 | synopsis: Helper functions for using yesod with colonnade 5 | description: Yesod and colonnade 6 | homepage: https://github.com/andrewthad/colonnade#readme 7 | license: BSD3 8 | license-file: LICENSE 9 | author: Andrew Martin 10 | maintainer: andrew.thaddeus@gmail.com 11 | copyright: 2018 Andrew Martin 12 | category: web 13 | build-type: Simple 14 | 15 | library 16 | hs-source-dirs: src 17 | exposed-modules: 18 | Yesod.Colonnade 19 | build-depends: 20 | base >= 4.9.1 && < 4.18 21 | , colonnade >= 1.2 && < 1.3 22 | , yesod-core >= 1.6 && < 1.7 23 | , conduit >= 1.3 && < 1.4 24 | , conduit-extra >= 1.3 && < 1.4 25 | , text >= 1.0 && < 2.1 26 | , blaze-markup >= 0.7 && < 0.9 27 | , blaze-html >= 0.8 && < 0.10 28 | , yesod-elements >= 1.1 && < 1.2 29 | default-language: Haskell2010 30 | 31 | source-repository head 32 | type: git 33 | location: https://github.com/andrewthad/colonnade 34 | --------------------------------------------------------------------------------