diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for KVITable + +## 0.1.0.0 -- 2021-01-30 + +* Initial version diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,13 @@ +Copyright (c) 2021 Kevin Quick + +Permission to use, copy, modify, and/or distribute this software for any purpose +with or without fee is hereby granted, provided that the above copyright notice +and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH +REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, +INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS +OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER +TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF +THIS SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,558 @@ +The `KVITable` is similar to a `Map`, but the keys to the map are a +list of `Key=Val` data. Although the `KVITable` is perfectly useable +as a container in this fashion, the main use of the `KVITable` is in +rendering this data in various configurations; because of this focus, +there is no particular attention to other container aspects such as: +performance, space usage, etc. + +An example table can be created via: + +```haskell +{-# LANGUAGE OverloadedStrings #-} +import qualified Data.Text as T +import Data.KVITable + +nestedTable = foldl foldlInsert + (mempty + & keyVals .~ [ ("millions", ["0"]) + , ("thousands", ["0"]) + , ("hundreds", ["0"]) + , ("tens", ["0"]) + , ("ones", ["0"]) + ] + ) + [ ([("millions", T.pack $ show m) + ,("thousands", T.pack $ show t) + ,("hundreds", T.pack $ show h) + ,("tens", T.pack $ show d) + ,("ones", T.pack $ show o)], + if (o `rem` 2) == 1 then "odd" else "even") + | m <- [0..2 :: Int] + , t <- [0..2 :: Int] + , h <- [1..2 :: Int] + , d <- [2..2 :: Int] + , o <- [0..1 :: Int] + ] +``` + +This Haskell code generates a table where the keys are the various +scale indicators along with a corresponding key value. The table +entries themselves are the words `odd` or `even`. + +Rendering this table in ASCII mode, with blank rows and columns +hidden, and enabling column stacking at the "hundreds" key column can +be done with the following code: + +```haskell +import Data.KVITable.Render.ASCII + +render (defaultRenderConfig { sortKeyVals = True + , rowRepeat = False + , hideBlankCols = True + , hideBlankRows = True + , equisizedCols = False + , colStackAt = Just "hundreds" + }) nestedTable +``` + +The output from this rendering will look like: + +``` +____ snip vv ____ +| millions | thousands | ___ 1 ____ | ___ 2 ____ | <- hundreds +| | | ___ 2 ____ | ___ 2 ____ | <- tens +| | | 0 | 1 | 0 | 1 | <- ones ++----------+-----------+------+-----+------+-----+ +| 0 | 0 | even | odd | even | odd | +| | 1 | even | odd | even | odd | +| | 2 | even | odd | even | odd | +| 1 | 0 | even | odd | even | odd | +| | 1 | even | odd | even | odd | +| | 2 | even | odd | even | odd | +| 2 | 0 | even | odd | even | odd | +| | 1 | even | odd | even | odd | +| | 2 | even | odd | even | odd | +____ snip ^^ ____ +``` + +When rendered to HTML instead by using the same code but importing +`Data.KVITable.Render.HTML` (and please use a little CSS to make +things prettier), the following is obtained: + +**** + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
millionsthousands12 ←hundreds
22 ←tens
0101 ←ones
00evenoddevenodd
1evenoddevenodd
2evenoddevenodd
10evenoddevenodd
1evenoddevenodd
2evenoddevenodd
20evenoddevenodd
1evenoddevenodd
2evenoddevenodd
+ +**** + +## Different ColStack specification + +By changing the `colStackAt` specification in the rendering +configuration from the "hundreds" column to the "thousands" column, +the column at which `Key Val`'s are shown as column headers instead of +rows is changed and the following ASCII results are obtained: + +``` +____ snip vv ____ +| millions | __________ 0 __________ | __________ 1 __________ | __________ 2 __________ | <- thousands +| | ___ 1 ____ | ___ 2 ____ | ___ 1 ____ | ___ 2 ____ | ___ 1 ____ | ___ 2 ____ | <- hundreds +| | ___ 2 ____ | ___ 2 ____ | ___ 2 ____ | ___ 2 ____ | ___ 2 ____ | ___ 2 ____ | <- tens +| | 0 | 1 | 0 | 1 | 0 | 1 | 0 | 1 | 0 | 1 | 0 | 1 | <- ones ++----------+------+-----+------+-----+------+-----+------+-----+------+-----+------+-----+ +| 0 | even | odd | even | odd | even | odd | even | odd | even | odd | even | odd | +| 1 | even | odd | even | odd | even | odd | even | odd | even | odd | even | odd | +| 2 | even | odd | even | odd | even | odd | even | odd | even | odd | even | odd | +____ snip ^^ ____ +``` + +or as HTML: + +**** + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
millions012 ←thousands
121212 ←hundreds
222222 ←tens
010101010101 ←ones
0evenoddevenoddevenoddevenoddevenoddevenodd
1evenoddevenoddevenoddevenoddevenoddevenodd
2evenoddevenoddevenoddevenoddevenoddevenodd
+ +**** + +## No column stacking + +Alternatively, the `colStackAt` rendering configuration parameter may +be specified as `Nothing`, indicating that all `Key Val` values are to +be specified on separate rows, with no stacked columns. The ASCII +form of this is: + +``` +____ snip vv ____ +| millions | thousands | hundreds | tens | ones | Value | ++----------+-----------+----------+------+------+-------+ +| 0 | 0 | 1 | 2 | 0 | even | +| | | | | 1 | odd | +| | | 2 | 2 | 0 | even | +| | | | | 1 | odd | +| | 1 | 1 | 2 | 0 | even | +| | | | | 1 | odd | +| | | 2 | 2 | 0 | even | +| | | | | 1 | odd | +| | 2 | 1 | 2 | 0 | even | +| | | | | 1 | odd | +| | | 2 | 2 | 0 | even | +| | | | | 1 | odd | +| 1 | 0 | 1 | 2 | 0 | even | +| | | | | 1 | odd | +| | | 2 | 2 | 0 | even | +| | | | | 1 | odd | +| | 1 | 1 | 2 | 0 | even | +| | | | | 1 | odd | +| | | 2 | 2 | 0 | even | +| | | | | 1 | odd | +| | 2 | 1 | 2 | 0 | even | +| | | | | 1 | odd | +| | | 2 | 2 | 0 | even | +| | | | | 1 | odd | +| 2 | 0 | 1 | 2 | 0 | even | +| | | | | 1 | odd | +| | | 2 | 2 | 0 | even | +| | | | | 1 | odd | +| | 1 | 1 | 2 | 0 | even | +| | | | | 1 | odd | +| | | 2 | 2 | 0 | even | +| | | | | 1 | odd | +| | 2 | 1 | 2 | 0 | even | +| | | | | 1 | odd | +| | | 2 | 2 | 0 | even | +| | | | | 1 | odd | +____ snip ^^ ____ +``` + +and the HTML form is + +**** + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
millionsthousandshundredstensonesValue
00120even
1odd
220even
1odd
1120even
1odd
220even
1odd
2120even
1odd
220even
1odd
10120even
1odd
220even
1odd
1120even
1odd
220even
1odd
2120even
1odd
220even
1odd
20120even
1odd
220even
1odd
1120even
1odd
220even
1odd
2120even
1odd
220even
1odd
+ +**** + +More examples can be found in the examples subdirectory, including: + + * [Zoo Inventory](examples/zoo.md) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/hundreds_all.md b/examples/hundreds_all.md new file mode 100644 --- /dev/null +++ b/examples/hundreds_all.md @@ -0,0 +1,241 @@ +This example uses the same generated `KVITable` data that was +described in the README, but formats the output differently. + +```haskell +render (defaultRenderConfig { KTR.sortKeyVals = True + , KTR.rowRepeat = False + , KTR.hideBlankCols = False + , KTR.hideBlankRows = False + , KTR.equisizedCols = False + , KTR.colStackAt = Just "hundreds" + } + ) + nestedTable +``` + +Here, the hiding of blank rows and columns is disabled, which makes +the table significantly larger: + +``` +____ snip vv ____ +| millions | thousands | _____ 0 _____ | _______ 1 ________ | _______ 2 ________ | <- hundreds +| | | _ 0 _ | _ 2 _ | _ 0 _ | ___ 2 ____ | _ 0 _ | ___ 2 ____ | <- tens +| | | 0 | 1 | 0 | 1 | 0 | 1 | 0 | 1 | 0 | 1 | 0 | 1 | <- ones ++----------+-----------+---+---+---+---+---+---+------+-----+---+---+------+-----+ +| 0 | 0 | | | | | | | even | odd | | | even | odd | +| | 1 | | | | | | | even | odd | | | even | odd | +| | 2 | | | | | | | even | odd | | | even | odd | +| 1 | 0 | | | | | | | even | odd | | | even | odd | +| | 1 | | | | | | | even | odd | | | even | odd | +| | 2 | | | | | | | even | odd | | | even | odd | +| 2 | 0 | | | | | | | even | odd | | | even | odd | +| | 1 | | | | | | | even | odd | | | even | odd | +| | 2 | | | | | | | even | odd | | | even | odd | +____ snip ^^ ____ +``` + +***** + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
millionsthousands012 ←hundreds
020202 ←tens
010101010101 ←ones
00evenoddevenodd
1evenoddevenodd
2evenoddevenodd
10evenoddevenodd
1evenoddevenodd
2evenoddevenodd
20evenoddevenodd
1evenoddevenodd
2evenoddevenodd
+ +***** + +## Equisized columns + +For the ASCII layout, the rendering configuration can set +`equisizedCols` to `True` to keep each column the same size. + +``` +____ snip vv ____ +| millions | thousands | ___________ 0 ___________ | ___________ 1 ___________ | ___________ 2 ___________ | <- hundreds +| | | ____ 0 ____ | ____ 2 ____ | ____ 0 ____ | ____ 2 ____ | ____ 0 ____ | ____ 2 ____ | <- tens +| | | 0 | 1 | 0 | 1 | 0 | 1 | 0 | 1 | 0 | 1 | 0 | 1 | <- ones ++----------+-----------+------+------+------+------+------+------+------+------+------+------+------+------+ +| 0 | 0 | | | | | | | even | odd | | | even | odd | +| | 1 | | | | | | | even | odd | | | even | odd | +| | 2 | | | | | | | even | odd | | | even | odd | +| 1 | 0 | | | | | | | even | odd | | | even | odd | +| | 1 | | | | | | | even | odd | | | even | odd | +| | 2 | | | | | | | even | odd | | | even | odd | +| 2 | 0 | | | | | | | even | odd | | | even | odd | +| | 1 | | | | | | | even | odd | | | even | odd | +| | 2 | | | | | | | even | odd | | | even | odd | +____ snip ^^ ____ +``` + +This setting has no effect on the HTML layout; to achieve the same +effect for HTML, CSS settings should be used. diff --git a/examples/zoo.md b/examples/zoo.md new file mode 100644 --- /dev/null +++ b/examples/zoo.md @@ -0,0 +1,433 @@ +In this example, the inventory of various Zoo animals from different +City Zoos is maintained in a `KVITable`, where each animal is +additionally classified by parameters such as Biome and Diet. + +The `KVITable` creation is somewhat lengthy due to the size of the +inventory; the [SampleTables.hs](../test/SampleTables.hs) file should be +consulted for the definition of the `KVITable` `zooTable` and +`zooTable2`. + +Rendering the data without any column stacking, but with multiple row +groupings: + +``` +import Data.KVITable.Render.ASCII + +render (defaultRenderConfig + { sortKeyVals = True + , rowRepeat = False + , rowGroup = [ "Location", "Biome", "Category" ] + }) + zooTable2 +``` + +results in the following: + +``` +____ snip vv ____ +| Location | Biome | Category | Diet | Name | Subtype | Count | ++-----------+----------+----------+-----------+---------+-------------+-------+ +| LA | Jungle | Animal | Herbivore | Hippo | | 1 | +| |----------+----------+-----------+---------+-------------+-------+ +| | Savannah | Animal | Carnivore | Lion | | 4 | +| | | | Herbivore | Giraffe | | 2 | +| | | | | Rhino | | 3 | ++-----------+----------+----------+-----------+---------+-------------+-------+ +| Miami | Polar | Bird | Carnivore | Penguin | Gentoo | 20 | +| |----------+----------+-----------+---------+-------------+-------+ +| | Savannah | Animal | Carnivore | Lion | | 2 | +| | | | Herbivore | Giraffe | Reticulated | 3 | ++-----------+----------+----------+-----------+---------+-------------+-------+ +| New York | Savannah | Animal | Carnivore | Lion | | 3 | ++-----------+----------+----------+-----------+---------+-------------+-------+ +| San Diego | Jungle | Animal | Omnivore | Bear | Sun | 1 | +| |----------+----------+-----------+---------+-------------+-------+ +| | Plains | Animal | Omnivore | Bear | Black | 1 | +| | | | | | Brown | 1 | +| |----------+----------+-----------+---------+-------------+-------+ +| | Polar | Animal | Omnivore | Bear | Polar | 1 | +| | |----------+-----------+---------+-------------+-------+ +| | | Bird | Carnivore | Penguin | Emperor | 8 | +| | | | | | Gentoo | 2 | +| |----------+----------+-----------+---------+-------------+-------+ +| | Savannah | Animal | Carnivore | Lion | | 9 | ++-----------+----------+----------+-----------+---------+-------------+-------+ +____ snip ^^ ____ +``` + +or in HTML (with CSS inherited from the Markdown +configuration... imagine how much nicer this could be with your own +CSS styling!): + +****** + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
LocationBiomeCategoryDietNameSubtypeCount
LAJungleAnimalHerbivoreHippo1
SavannahAnimalCarnivoreLion4
HerbivoreGiraffe2
Rhino3
MiamiPolarBirdCarnivorePenguinGentoo20
SavannahAnimalCarnivoreLion2
HerbivoreGiraffeReticulated3
New YorkSavannahAnimalCarnivoreLion3
San DiegoJungleAnimalOmnivoreBearSun1
PlainsAnimalOmnivoreBearBlack1
Brown1
PolarAnimalOmnivoreBearPolar1
BirdCarnivorePenguinEmperor8
Gentoo2
SavannahAnimalCarnivoreLion9
+ +****** + +## With Column Stacking + +Removing the "Subtype" field from the zoo table and then modifying the +rendering configuration to add column stacking on the `"Name"` key +`Val`s results in: + +``` +____ snip vv ____ +| Location | Biome | Category | Diet | Bear | Giraffe | Hippo | Lion | Penguin | Rhino | <- Name ++-----------+----------+----------+-----------+------+---------+-------+------+---------+-------+ +| LA | Jungle | Animal | Herbivore | | | 1 | | | | +| |----------+----------+-----------+------+---------+-------+------+---------+-------+ +| | Savannah | Animal | Carnivore | | | | 4 | | | +| | | | Herbivore | | 2 | | | | 3 | ++-----------+----------+----------+-----------+------+---------+-------+------+---------+-------+ +| Miami | Polar | Bird | Carnivore | | | | | 20 | | +| |----------+----------+-----------+------+---------+-------+------+---------+-------+ +| | Savannah | Animal | Carnivore | | | | 2 | | | +| | | | Herbivore | | 3 | | | | | ++-----------+----------+----------+-----------+------+---------+-------+------+---------+-------+ +| New York | Savannah | Animal | Carnivore | | | | 3 | | | ++-----------+----------+----------+-----------+------+---------+-------+------+---------+-------+ +| San Diego | Jungle | Animal | Omnivore | 1 | | | | | | +| |----------+----------+-----------+------+---------+-------+------+---------+-------+ +| | Plains | Animal | Omnivore | 2 | | | | | | +| |----------+----------+-----------+------+---------+-------+------+---------+-------+ +| | Polar | Animal | Omnivore | 1 | | | | | | +| | |----------+-----------+------+---------+-------+------+---------+-------+ +| | | Bird | Carnivore | | | | | 10 | | +| |----------+----------+-----------+------+---------+-------+------+---------+-------+ +| | Savannah | Animal | Carnivore | | | | 9 | | | ++-----------+----------+----------+-----------+------+---------+-------+------+---------+-------+ +____ snip ^^ ____ +``` + +And as HTML: + +****** + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
LocationBiomeCategoryDietBearGiraffeHippoLionPenguinRhino ←Name
LAJungleAnimalHerbivore + + 1 + + +
SavannahAnimalCarnivore + + + 4 + +
Herbivore + 2 + + + 3
MiamiPolarBirdCarnivore + + + + 20 +
SavannahAnimalCarnivore + + + 2 + +
Herbivore + 3 + + + +
New YorkSavannahAnimalCarnivore + + + 3 + +
San DiegoJungleAnimalOmnivore1 + + + + +
PlainsAnimalOmnivore2 + + + + +
PolarAnimalOmnivore1 + + + + +
BirdCarnivore + + + + 10 +
SavannahAnimalCarnivore9
+ +****** diff --git a/kvitable.cabal b/kvitable.cabal new file mode 100644 --- /dev/null +++ b/kvitable.cabal @@ -0,0 +1,74 @@ +cabal-version: >=1.10 +name: kvitable +version: 1.0.0.0 +synopsis: Key/Value Indexed Table container and formatting library +description: + . + Allows creation of a table from a set of of Key+Value Indices. + This differs from the standard 'Map' structure in that the 'Map' + simply indexes by value but the KVI table indexes by a + heterogeneous list of keys along with their associated values. + This effectively creates an N-dimensional table, where + @N=Product(Count(Values[key]))@. The table contents can be sparse. + . + This library also provides the ability to format multi-dimensional + data in a table presentation. The table is automatically formatted + and can be output in a number of different styles (ascii, html, + etc.) + . + Multi-dimensional data is more difficult to represent than simple + two-dimensional data; this package provides the ability to select + which dimensions should be represented as sub-rows and which + dimensions should be represented as sub-columns. See the README + for examples + +-- bug-reports: +license: ISC +license-file: LICENSE +author: Kevin Quick +maintainer: kquick@galois.com +copyright: Kevin Quick, 2021 +category: Text +build-type: Simple +tested-with: GHC ==8.6.5 GHC ==8.8.4 GHC ==8.10.4 GHC ==9.0.1 +extra-source-files: CHANGELOG.md + , examples/hundreds_all.md + , examples/zoo.md + , README.md + +library + hs-source-dirs: src + default-language: Haskell2010 + GHC-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wpartial-fields -fhide-source-paths + -- other-extensions: + exposed-modules: Data.KVITable + , Data.KVITable.Render + , Data.KVITable.Render.ASCII + , Data.KVITable.Render.HTML + -- other-modules: + build-depends: base >=4.12 && <4.16 + , containers >= 0.6 && < 0.7 + , lucid >= 2.9 && < 2.10 + , microlens >= 0.4 && < 0.5 + , prettyprinter >= 1.7 && < 1.8 + , text >= 1.2 && < 1.3 + +test-suite test-kvitable + type: exitcode-stdio-1.0 + hs-source-dirs: test + default-language: Haskell2010 + GHC-options: -fhide-source-paths + main-is: TestMain.hs + other-modules: AsciiRenderTests + , HTMLRenderTests + , SampleTables + , TestQQDefs + build-depends: base + , html-parse + , kvitable + , microlens + , pretty-show + , tasty + , tasty-hunit + , template-haskell + , text diff --git a/src/Data/KVITable.hs b/src/Data/KVITable.hs new file mode 100644 --- /dev/null +++ b/src/Data/KVITable.hs @@ -0,0 +1,343 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The 'KVITable' is similar to a 'Data.Map', but the keys for a +-- 'KVITable' are made up of sequences of @Key=Val@ values. The +-- primary use of a 'KVITable' is for rendering the information in +-- various configurations and formats, although it may be used like +-- any other container. + +module Data.KVITable + ( + KVITable(KVITable) + , Key + , KeyVal + , KeyVals + , KeySpec + , fromList + , toList + , Data.KVITable.lookup + , keyVals + , keyValGen + , valueColName + , insert + , foldlInsert + , Data.KVITable.filter + , adjust + , adjustWithKey + , delete + , update + , updateWithKey + , rows + ) +where + +import Data.Function ( on ) +import qualified Data.List as L +import qualified Data.Map as Map +import Data.Text ( Text ) +import qualified GHC.Exts +import Lens.Micro ( Lens' ) + + +-- | The core KeyValue Indexed Table. This table is similar to a Map, +-- but the values are indexed by a list of Key+Value combinations, and +-- the table contents can be sparse. + +-- KWQ: make fields strict? check with tasty-bench + +data KVITable v = KVITable + { keyvals :: KeyVals -- ^ allowed value for keys (in order) + + , keyvalGen :: Key -> KeyVal + -- ^ Function to generate the keyval if the keyval is not + -- explicitly provided. Provided with the Key and returns the + -- KeyVal that should be used. + + , contents :: Map.Map KeySpec v + -- ^ Internal contents of the KVITable + + -- The invariant for the KVITable contents is that each KeySpec + -- contains all keys listed in keyvals (in the same order) with + -- the defaultKeyVal for any keys not explicitly provided for that + -- value. + + , valuecolName :: Text -- ^ name of the value cells + } + +instance Eq v => Eq (KVITable v) where + -- n.b. keyvals (i.e. metadata) are _not_ used for equality, only contents + (==) = (==) `on` contents + +instance Show v => Show (KVITable v) where + show t = "KVITable {" <> + " keyvals = " <> show (keyvals t) <> + " contents = " <> show (contents t) <> + ", valuecolName = " <> show (valuecolName t) <> + "}" + +-- | The 'Key' is the first half of a tuple that makes up the list of +-- keys (the 'KeySpec'). The second half is the 'KeyVal'. +type Key = Text + +-- | The 'KeyVal' is the first half of a tuple that makes up the list of +-- keys (the 'KeySpec'). The first half is the 'Key'. +type KeyVal = Text + +-- | The 'KeySpec' is the list of tuples and defines the unique key +-- for a value in the 'KVITable'. +type KeySpec = [ (Key, KeyVal ) ] + +-- | The 'KeyVals' specifies all valid values for a particular 'Key' +-- in the 'KVITable'. The set of 'KeyVals' can be provided at the +-- initialization of the 'KVITable' to ensure specific values are +-- considered (especially if rendering includes blank rows or +-- columns); if entries are added to the table with a 'KeyVal' +-- previously unknown for the 'Key', the 'KeyVals' for the table is +-- automatically updated to include the new 'KeyVal'. +type KeyVals = [ (Key, [KeyVal]) ] + +-- | The KVITable semigroup is left biased (same as Data.Map). Note +-- that joining tables can result in a table that has a different +-- keyVals sequence than either input table. + +instance Semigroup (KVITable v) where + a <> b = foldl foldlInsert + (mempty { valuecolName = valuecolName a + , keyvals = keyvals a + }) + (toList b <> toList a) + +instance Monoid (KVITable v) where + mempty = KVITable { keyvals = mempty + , keyvalGen = const "" + , contents = mempty + , valuecolName = "Value" + } + +instance Functor KVITable where + fmap f t = KVITable { contents = fmap f (contents t) + , keyvalGen = keyvalGen t + , keyvals = keyvals t + , valuecolName = valuecolName t + } + +instance Foldable KVITable where + foldMap f = foldMap f . contents + +instance Traversable KVITable where + traverse f t = (\c -> KVITable { contents = c + , valuecolName = valuecolName t + , keyvals = keyvals t + , keyvalGen = keyvalGen t + } + ) <$> traverse f (contents t) + +instance GHC.Exts.IsList (KVITable v) where + type Item (KVITable v) = (KeySpec, v) + fromList = foldl foldlInsert mempty + toList = GHC.Exts.toList . contents + + +-- | Converts a list of @([(Key,Val)], Value)@ tuples to a KVI table. + +fromList :: [ GHC.Exts.Item (KVITable v) ] -> KVITable v +fromList = GHC.Exts.fromList + +-- | Converts a KVI table to a list of @([(Key,Val)], Value)@ tuples. + +toList :: KVITable v -> [ GHC.Exts.Item (KVITable v) ] +toList = GHC.Exts.toList + + +-- | Fetch or set the keyvals list via lenses. Note that setting the +-- keyval list will drop any current contents in the table that do not +-- have entries in the keyvals list. + +keyVals :: Lens' (KVITable v) KeyVals +keyVals f t = (\kvs -> + t { keyvals = kvs + , contents = + let inKVS spec _ = inkv spec kvs + inkv [] [] = True + inkv ((sk,sv):srs) ((k,vs):kv) + | sk == k && sv `elem` vs = inkv srs kv + inkv _ _ = False + in Map.filterWithKey inKVS (contents t) + } + ) <$> f (keyvals t) + + +-- | Fetch or set the default 'KeyVal' generator for this 'KVITable' + +keyValGen :: Lens' (KVITable v) (Key -> KeyVal) +keyValGen f t = (\n -> t { keyvalGen = n } ) <$> f (keyvalGen t) + +-- | Fetch or set the column name for the actual value cell in the +-- 'KVITable'. + +valueColName :: Lens' (KVITable v) Text +valueColName f t = (\n -> t { valuecolName = n } ) <$> f (valuecolName t) + + +-- | Retrieve an entry from the KVITable given a keyspec. The keyspec +-- may be minimally specified (i.e. it does not need to contain keys +-- whose value is the default key value) and it may present the keys +-- out of order and the lookup will still succeed (if there is a value +-- for the normalized keyspec), but it will be faster to use the +-- normalized key directly. + +lookup :: KeySpec -> KVITable v -> Maybe v +lookup keyspec t = case Map.lookup keyspec $ contents t of + Just v -> Just v + Nothing -> + -- keyspec might be under-specified or in a different order + let ks = normalizeKeySpec t keyspec + in Map.lookup ks $ contents t + +normalizeKeySpec :: KVITable v -> KeySpec -> KeySpec +normalizeKeySpec t keyspec = + let keyandval s (k,vs) = case L.lookup k keyspec of + Just v -> if v `elem` vs then s <> [(k,v)] + else s -- no level added, so this should never match in the Map + Nothing -> s <> [(k, keyvalGen t k)] + in foldl keyandval [] (keyvals t) + +-- | Inserts a new cell value into the table at the specified keyspec +-- location. The keyspec may be minimally specified and out-of-order. +-- +-- This may be an expensive operation if it has to extend the keyvals +-- for the table. In general, insertion is expected to be less +-- frequent than lookups so computation costs are biased towards the +-- insertion operation. + +insert :: KeySpec -> v -> KVITable v -> KVITable v +insert keyspec val t = endset t val (keyvals t) keyspec [] [] + +remainingKeyValDefaults :: KVITable v -> [(Key,a)] -> KeySpec +remainingKeyValDefaults t = fmap (\(k,_) -> (k, keyvalGen t k)) + +addDefVal :: KVITable v -> (Key, [KeyVal]) -> (Key, [KeyVal]) +addDefVal t e@(k,vs) = if (keyvalGen t k) `elem` vs + then e + else (k, keyvalGen t k : vs) + +endset :: KVITable v -> v -> KeyVals -> KeySpec -> KeySpec -> KeyVals -> KVITable v +endset t val rkv [] tspec kvbld = + -- Reached the end of the user's keyspec but there are more + -- known keyvals in this KVITable, so add the entry with the + -- default KeyVal for the remaining keyspec (and ensure the + -- default KeyVal is listed in the table's keyvals). + let spec = tspec <> remainingKeyValDefaults t rkv + in t { contents = Map.insert spec val (contents t) + , keyvals = kvbld <> (addDefVal t <$> rkv) + } + +endset t val [] spec tspec kvbld = + -- Reached the end of the known keyvals for this table but the + -- user's keyspec has additional elements. This should extend + -- the tables keyvals with the remaining keyspec; also all + -- existing table values should be pushed out to use the + -- default values for the new keys in their keyspec. + let spec' = tspec <> spec + keySpecElemToKeyVals (k,v) = (k, if null curTblList + then [v] + else [v, keyvalGen t k]) + keyvals' = kvbld <> (keySpecElemToKeyVals <$> spec) + curTblList = Map.toList $ contents t + defaultsExtension = remainingKeyValDefaults t spec + updTblList = fmap (\(ks,v) -> (ks <> defaultsExtension, v)) curTblList + in t { contents = Map.insert spec' val $ Map.fromList updTblList + , keyvals = keyvals' + } + +endset t val kvs@((k,vs):rkvs) ((sk,sv):srs) tspec kvbld = + if k == sk + then let kv' = if sv `elem` vs + then kvbld <> [(k, vs)] + else kvbld <> [(k, sv : vs)] + in endset t val rkvs srs (tspec <> [(k,sv)]) kv' + else + -- re-arrange user spec crudely by throwing invalid + -- candidates to the end and retrying. This isn't + -- necessarily efficient, but keyspecs aren't expected to be + -- longer than about a dozen entries. + if sk `elem` (fst <$> rkvs) && k `elem` (fst <$> srs) + then endset t val kvs (srs <> [(sk,sv)]) tspec kvbld + else + if any (`elem` (fst <$> kvs)) (fst <$> srs) + then endset t val kvs (srs <> [(sk,sv)]) tspec kvbld + else + let defVal = keyvalGen t k + vs' = if defVal `elem` vs then vs else (defVal : vs) + in endset t val rkvs ((sk,sv):srs) (tspec <> [(k,defVal)]) (kvbld <> [(k,vs')]) + + +-- | The foldlInsert is a convenience function that can be specified +-- as the function argument of a foldl operation over the list form of +-- a KVITable to generate the associated KVITable. + +foldlInsert :: KVITable v -> (KeySpec, v) -> KVITable v +foldlInsert t (k,v) = insert k v t + + +-- | Filter 'KVITable' to retain only the elements that satisfy some predicate. + +filter :: ((KeySpec, v) -> Bool) -> KVITable v -> KVITable v +filter f t = foldl chkInsert (emptyClone t) $ toList t + where emptyClone o = o { contents = mempty } + chkInsert o (k,v) = if f (k,v) then insert k v o else o + +-- | Delete the value at the specified keyspec location in the +-- 'KVITable'. If the keyspec does not exist, the original table is +-- returned. + +delete :: KeySpec -> KVITable v -> KVITable v +delete k t = t { contents = Map.delete (normalizeKeySpec t k) $ contents t } + +-- | Adjust a value at the specified keyspec; return the original +-- 'KVITable' if that keyspec is not found in the table. + +adjustWithKey :: (KeySpec -> v -> v) -> KeySpec -> KVITable v -> KVITable v +adjustWithKey f k t = + t { contents = Map.adjustWithKey f (normalizeKeySpec t k) $ contents t } + +-- | Adjust a value at the specified keyspec; return the original +-- 'KVITable' if that keyspec is not found in the table. + +adjust :: (v -> v) -> KeySpec -> KVITable v -> KVITable v +adjust f k t = t { contents = Map.adjust f (normalizeKeySpec t k) $ contents t } + +-- | Update the 'KVITable' to remove or set a new value for the +-- specified entry if the updating function returns @Nothing@ or @Just +-- v@, respectively. The update function is passed both the keyspec +-- and the current value at that key. If the value does not exist in +-- the table, the original table is returned. + +updateWithKey :: (KeySpec -> v -> Maybe v) -> KeySpec -> KVITable v -> KVITable v +updateWithKey f k t = + t { contents = Map.updateWithKey f (normalizeKeySpec t k) $ contents t } + +-- | Update the 'KVITable' to remove or set a new value for the +-- specified entry if the updating function returns @Nothing@ or @Just +-- v@, respectively. The update function is passed the value for the +-- keyspec to be updated. If the value does not exist in the table, +-- the original table is returned. + +update :: (v -> Maybe v) -> KeySpec -> KVITable v -> KVITable v +update f k t = t { contents = Map.update f (normalizeKeySpec t k) $ contents t } + +-- | The 'rows' function returns a set of rows for the 'KVITable' as a +-- list structure, where each list entry is a different row. A row +-- consists of the /values/ of the keys for that row followed by the +-- value of the entry (to get the names of the keys, use 'keyVals'). + +rows :: KVITable v -> [ ([KeyVal], v) ] +rows t = go (keyvals t) [] + where + go [] spec = let spec' = reverse spec + in case Map.lookup spec' (contents t) of + Nothing -> [] + Just v -> [ (snd <$> spec', v) ] + go ((key, vals):kvs) spec = + concatMap (\v -> let spec' = (key,v):spec in go kvs spec') vals diff --git a/src/Data/KVITable/Render.hs b/src/Data/KVITable/Render.hs new file mode 100644 --- /dev/null +++ b/src/Data/KVITable/Render.hs @@ -0,0 +1,96 @@ +-- | Common definitions (and support functions) for rendering a +-- 'KVITable'. + +module Data.KVITable.Render + ( + RenderConfig(..) + , defaultRenderConfig + , sortWithNums + ) +where + +import Data.KVITable +import qualified Data.List as L +import Data.Text ( Text ) +import qualified Data.Text as T + +-- | Returns the default rendering configuration, to be used with a +-- format-specific @render@ call. + +defaultRenderConfig :: RenderConfig +defaultRenderConfig = RenderConfig + { hideBlankRows = True + , hideBlankCols = True + , equisizedCols = True + , sortKeyVals = False + , colStackAt = Nothing + , rowRepeat = True + , rowGroup = [] + , caption = Nothing + } + +-- | The 'RenderConfig' specifies the various controls and +-- configurations used when rendering a 'KVITable' in various formats. +-- The 'RenderConfig' is global t oall formats, although some of the +-- fields in the 'RenderConfig' will be ignored as not-applicable by +-- some formats. + +data RenderConfig = RenderConfig + { + hideBlankRows :: Bool + -- ^ 'True' (default) removes rows for which there are no values + + , hideBlankCols :: Bool + -- ^ 'True' (default) removes columns for which there are no values + + , equisizedCols :: Bool + -- ^ 'True' (default) to maintain a consistent column width, + -- otherwise the columns are shunk to the minimum size needed to + -- display the title and values. Not applicable for some backends + -- (e.g. HTML) where the backend provides table rendering + -- functionality. + + , sortKeyVals :: Bool + -- ^ 'True' (default is False) to sort the KeyVal entries when + -- rendering a table. + + , colStackAt :: Maybe Key + -- ^ Column key to begin stacking keys in columns and sub-columns + -- rather than creating additional sub-rows. + + , rowRepeat :: Bool + -- ^ 'True' (default) if an identical 'KeyVal' is to be repeated + -- in subsequent applicable rows. + + , rowGroup :: [Key] + -- ^ List of Key names that should by grouped by inserting + -- horizontal row lines between KeyVals + + , caption :: Maybe Text + -- ^ Caption to render for table for backends which support + -- captions; otherwise ignored. + } + + + +-- | Sorting for KeyVals. If the value starts or ends with a digit, +-- then this should do a rough numeric sort on the expectation that +-- the digits represent a version or some other numeric value. As an +-- approximation of a numeric sort, sort by word size and then string +-- value. This will result in [ "1", "2", "10", "50", "400" ], but +-- would fail with [ "v1.0", "v2.0", "v3.0", "v2.0.5", "v1.0.0.3" ], +-- but it's a reasonably fast heuristic and probably better than a +-- straight ascii sort. +-- +-- This function is used by the 'KVITable' rendering functions. + +sortWithNums :: [KeyVal] -> [KeyVal] +sortWithNums kvs = + let skvs = zip (rank <$> kvs) kvs + rank e = if (not $ T.null e) && + or [ T.head e `elem` ['0'..'9'] + , T.last e `elem` ['0'..'9'] + ] + then T.length e + else 0 + in snd <$> L.sort skvs diff --git a/src/Data/KVITable/Render/ASCII.hs b/src/Data/KVITable/Render/ASCII.hs new file mode 100644 --- /dev/null +++ b/src/Data/KVITable/Render/ASCII.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +-- | This module provides the 'KVITable' 'render' function for +-- rendering the table in a plain ASCII format. + +module Data.KVITable.Render.ASCII + ( + render + -- re-export Render definitions to save the caller an additional import + , RenderConfig(..) + , defaultRenderConfig + ) +where + +import qualified Data.List as L +import Data.Maybe ( fromMaybe, isNothing ) +import Data.Text ( Text ) +import qualified Data.Text as T +import Lens.Micro ( (^.) ) +import qualified Prettyprinter as PP + +import Data.KVITable +import Data.KVITable.Render + +import Prelude hiding ( lookup ) + + +-- | Renders the specified table in ASCII format, using the specified +-- 'RenderConfig' controls. + +render :: PP.Pretty v => RenderConfig -> KVITable v -> Text +render cfg t = + let kseq = fst <$> t ^. keyVals + (fmt, hdr) = renderHdrs cfg t kseq + bdy = renderSeq cfg fmt kseq t + in T.unlines $ hdr <> bdy + +---------------------------------------------------------------------- + +data FmtLine = FmtLine [Int] Sigils Sigils -- last is for sepline +data Sigils = Sigils { sep :: Text, pad :: Text, cap :: Text } + +fmtLine :: [Int] -> FmtLine +fmtLine cols = FmtLine cols + Sigils { sep = "|", pad = " ", cap = "_" } + Sigils { sep = "+", pad = "-", cap = "_" } + +fmtColCnt :: FmtLine -> Int +fmtColCnt (FmtLine cols _ _) = length cols + +perColOvhd :: Int +perColOvhd = 2 -- pad chars on either side of each column's entry + +-- | Formatted width of output, including pad on either side of each +-- column's value (but not the outer set), and a separator between columns. +-- +-- Note that a column size of 0 indicates that hideBlankCols is active +-- and the column was found to be empty of values, so it should not be +-- counted. +fmtWidth :: FmtLine -> Int +fmtWidth (FmtLine cols _ _) = + let cols' = L.filter (/= 0) cols + in sum cols' + ((perColOvhd + 1) * (length cols' - 1)) + +fmtEmptyCols :: FmtLine -> Bool +fmtEmptyCols (FmtLine cols _ _) = sum cols == 0 + +fmtAddColLeft :: Int -> FmtLine -> FmtLine +fmtAddColLeft leftCol (FmtLine cols s s') = FmtLine (leftCol : cols) s s' + +data FmtVal = Separator | TxtVal Text | CenterVal Text + +fmtRender :: FmtLine -> [FmtVal] -> Text +fmtRender (FmtLine [] _sigils _sepsigils) [] = "" +fmtRender (FmtLine cols sigils sepsigils) vals = + if length cols == length vals + then let sig f o = case o of + Separator -> f sepsigils + TxtVal _ -> f sigils + CenterVal _ -> f sigils + l = sig sep $ head vals + in l <> + T.concat + [ sig pad fld <> + (case fld of + Separator -> T.pack (replicate sz '-') + TxtVal v -> T.pack (replicate (sz - T.length v) ' ') <> v + CenterVal t -> let (w,e) = (sz - T.length t - 2) `divMod` 2 + m = cap sigils + ls = T.replicate (w + 0) m + rs = T.replicate (w + e) m + in if T.length t + 2 >= sz + then (T.replicate (sz - T.length t) " ") <> t + else ls <> " " <> t <> " " <> rs + ) <> + sig pad fld <> + sig sep fld -- KWQ or if next fld is Nothing + | (sz,fld) <- zip cols vals, sz /= 0 + ] + else error ("Insufficient arguments (" <> + show (length vals) <> ")" <> + " for FmtLine " <> show (length cols)) + +---------------------------------------------------------------------- + +data HeaderLine = HdrLine FmtLine HdrVals Trailer +type HdrVals = [FmtVal] +type Trailer = Text + +hdrFmt :: HeaderLine -> FmtLine +hdrFmt (HdrLine fmt _ _) = fmt + +renderHdrs :: PP.Pretty v => RenderConfig -> KVITable v -> [Key] -> (FmtLine, [Text]) +renderHdrs cfg t keys = + ( lastFmt + , [ fmtRender fmt hdrvals + <> (if T.null trailer then "" else (" <- " <> trailer)) + | (HdrLine fmt hdrvals trailer) <- hrows + ] <> + [ fmtRender lastFmt (replicate (fmtColCnt lastFmt) Separator) ]) + where + hrows = hdrstep cfg t keys + lastFmt = if null hrows then fmtLine [] else hdrFmt $ head $ reverse hrows + +hdrstep :: PP.Pretty v => RenderConfig -> KVITable v -> [Key] -> [HeaderLine] +hdrstep _cfg t [] = + -- colStackAt wasn't recognized, so devolve into a non-colstack table + let valcoltxt = t ^. valueColName + valcoltsz = T.length valcoltxt + valsizes = length . show . PP.pretty . snd <$> toList t + valwidth = maximum $ valcoltsz : valsizes + in [ HdrLine (fmtLine [valwidth]) [TxtVal valcoltxt] "" ] +hdrstep cfg t (key:keys) = + if colStackAt cfg == Just key + then hdrvalstep cfg t [] (key:keys) -- switch to column-stacking mode + else + let keyw = maximum ( T.length key : + fmap T.length (fromMaybe [] $ L.lookup key $ t ^. keyVals) ) + mkhdr (hs, v) (HdrLine fmt hdrvals trailer) = + ( HdrLine (fmtAddColLeft keyw fmt) (TxtVal v : hdrvals) trailer : hs , "") + in reverse $ fst $ foldl mkhdr ([], key) $ hdrstep cfg t keys + -- first line shows hdrval for non-colstack'd columns, others are blank + +hdrvalstep :: PP.Pretty v => RenderConfig -> KVITable v -> KeySpec -> [Key] -> [HeaderLine] +hdrvalstep _ _ _ [] = error "ASCII hdrvalstep with empty keys after matching colStackAt -- impossible" +hdrvalstep cfg t steppath (key:[]) = + let titles = ordering $ fromMaybe [] $ L.lookup key $ t ^. keyVals + ordering = if sortKeyVals cfg then sortWithNums else id + cvalWidths kv = fmap (length . show . PP.pretty . snd) $ + L.filter ((L.isSuffixOf (steppath <> [(key, kv)])) . fst) $ + toList t + colWidth kv = let cvw = cvalWidths kv + in if and [ hideBlankCols cfg, sum cvw == 0 ] + then 0 + else maximum $ T.length kv : cvw + cwidths = fmap colWidth titles + fmtcols = if equisizedCols cfg + then (replicate (length cwidths) (maximum cwidths)) + else cwidths + in [ HdrLine (fmtLine $ fmtcols) (TxtVal <$> titles) key ] +hdrvalstep cfg t steppath (key:keys) = + let vals = ordering $ fromMaybe [] $ L.lookup key $ t ^. keyVals + ordering = if sortKeyVals cfg then sortWithNums else id + subhdrsV v = hdrvalstep cfg t (steppath <> [(key,v)]) keys + subTtlHdrs = let subAtVal v = (T.length v, subhdrsV v) + in fmap subAtVal vals + szexts = let subVW = fmtWidth . hdrFmt . head + subW (hl,sh) = let sv = subVW sh + in if and [ hideBlankCols cfg, + fmtEmptyCols $ hdrFmt $ head sh + ] + then (0, 0) + else (hl, sv) + in fmap (uncurry max . subW) subTtlHdrs + rsz_extsubhdrs = fmap hdrJoin $ + L.transpose $ + fmap (uncurry rsz_hdrstack) $ + zip szhdrs $ fmap snd subTtlHdrs + largest = maximum szexts + szhdrs = if equisizedCols cfg && not (hideBlankCols cfg) + then replicate (length vals) largest + else szexts + rsz_hdrstack s vhs = fmap (rsz_hdrs s) vhs + rsz_hdrs hw (HdrLine (FmtLine c s j) v r) = + let nzCols = L.filter (/= 0) c + pcw = sum nzCols + ((perColOvhd + 1) * (length nzCols - 1)) + (ew,w0) = let l = length nzCols + in if l == 0 then (0,0) + else max 0 (hw - pcw) `divMod` length nzCols + c' = fst $ foldl (\(c'',n) w -> (c''<>[n+w],ew)) ([],ew+w0) c + in HdrLine (FmtLine c' s j) v r + hdrJoin hl = foldl hlJoin (HdrLine (fmtLine []) [] "") hl + hlJoin (HdrLine (FmtLine c s j) v _) (HdrLine (FmtLine c' _ _) v' r) = + HdrLine (FmtLine (c<>c') s j) (v<>v') r + tvals = fmap CenterVal vals + in HdrLine (fmtLine szhdrs) tvals key : rsz_extsubhdrs + +renderSeq :: PP.Pretty v => RenderConfig -> FmtLine -> [Key] -> KVITable v -> [Text] +renderSeq cfg fmt keys kvitbl = fmtRender fmt . snd <$> asciiRows keys [] + where + asciiRows :: [Key] -> KeySpec -> [ (Bool, [FmtVal]) ] + asciiRows [] path = + let v = lookup path kvitbl + skip = case v of + Nothing -> hideBlankRows cfg + Just _ -> False + in if skip then [] + else [ (False, [ maybe (TxtVal "") TxtVal (T.pack . show . PP.pretty <$> v) ]) ] + asciiRows (key:kseq) path + | colStackAt cfg == Just key = + let filterOrDefaultBlankRows = + fmap (fmap defaultBlanks) . + if hideBlankRows cfg + then L.filter (not . all isNothing . snd) + else id + defaultBlanks = fmap (\v -> maybe (TxtVal "") TxtVal v) + in filterOrDefaultBlankRows $ [ (False, multivalRows (key:kseq) path) ] + | otherwise = + let subrows keyval = asciiRows kseq $ path <> [ (key, keyval) ] + grprow subs = if key `elem` rowGroup cfg && not (null subs) + then let subl = [ (True, replicate (length $ snd $ head subs) Separator) ] + in if fst (last subs) + then init subs <> subl + else subs <> subl + else subs + addSubrows ret keyval = ret <> (grprow $ fst $ + foldl leftAdd ([],keyval) $ subrows keyval) + leftAdd (acc,kv) (b,subrow) = (acc <> [ (b, TxtVal kv : subrow) ], + if rowRepeat cfg then kv else "") + ordering = if sortKeyVals cfg then sortWithNums else id + in foldl addSubrows [] $ ordering $ fromMaybe [] $ L.lookup key $ kvitbl ^. keyVals + multivalRows :: [Key] -> KeySpec -> [ Maybe Text ] + multivalRows (key:[]) path = + let ordering = if sortKeyVals cfg then sortWithNums else id + keyvals = ordering $ fromMaybe [] $ L.lookup key $ kvitbl ^. keyVals + showEnt = T.pack . show . PP.pretty + in (\v -> (showEnt <$> (lookup (path <> [(key,v)]) kvitbl))) <$> keyvals + multivalRows (key:kseq) path = + let ordering = if sortKeyVals cfg then sortWithNums else id + keyvals = ordering $ fromMaybe [] $ L.lookup key $ kvitbl ^. keyVals + in concatMap (\v -> multivalRows kseq (path <> [(key,v)])) keyvals + multivalRows [] _ = error "multivalRows cannot be called with no keys!" diff --git a/src/Data/KVITable/Render/HTML.hs b/src/Data/KVITable/Render/HTML.hs new file mode 100644 --- /dev/null +++ b/src/Data/KVITable/Render/HTML.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | This module provides the 'KVITable' 'render' function for +-- rendering the table in a HTML table format. The various HTML table +-- entries have class designators that allow the user to provide CSS +-- to adjust the appearance of the table. + +module Data.KVITable.Render.HTML + ( + render + -- re-export Render definitions to save the caller an additional import + , RenderConfig(..) + , defaultRenderConfig + ) +where + +import qualified Data.Foldable as F +import qualified Data.List as L +import Data.Maybe ( fromMaybe, isNothing ) +import Data.Text ( Text ) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Lens.Micro ( (^.) ) +import Lucid +import qualified Prettyprinter as PP + +import Data.KVITable +import Data.KVITable.Render + +import Prelude hiding ( lookup ) + + +-- | Renders the specified table in HTML format, using the specified +-- 'RenderConfig' controls. The output is only the @@ +-- definition; it is intended to be embedded in a larger HTML +-- document. + +render :: PP.Pretty v => RenderConfig -> KVITable v -> Text +render cfg t = + let kseq = fst <$> t ^. keyVals + (fmt, hdr) = renderHdrs cfg t kseq + bdy = renderSeq cfg fmt kseq t + in TL.toStrict $ renderText $ + table_ [ class_ "kvitable" ] $ + do maybe mempty (caption_ . toHtml) $ Data.KVITable.Render.caption cfg + thead_ [ class_ "kvitable_head" ] hdr + tbody_ [ class_ "kvitable_body" ] bdy + +---------------------------------------------------------------------- + +data FmtLine = FmtLine [Int] -- colspans, length is # columns + +instance Semigroup FmtLine where + (FmtLine c1) <> (FmtLine c2) = FmtLine $ c1 <> c2 + +instance Monoid FmtLine where + mempty = FmtLine mempty + +fmtAddColLeft :: Int -> FmtLine -> FmtLine +fmtAddColLeft lspan (FmtLine col) = FmtLine $ lspan : col + +data FmtVal = Val Height LastInGroup Text + | Hdr Height LastInGroup Text + deriving Show +type Height = Int +type LastInGroup = Bool +type RightLabel = Text + +fmtRender :: FmtLine -> [FmtVal] -> Maybe RightLabel -> Html () +fmtRender (FmtLine cols) vals mbRLabel = do + tr_ [ class_ "kvitable_tr" ] $ + let excessColCnt = length cols - length vals + cell (w,Hdr h l v) = + let a = [ [ class_ "kvitable_th" ] + , if h == 1 then [] + else [ rowspan_ $ T.pack $ show h ] + , if w == 1 then [] + else [ colspan_ $ T.pack $ show w + , class_ " multicol" ] + , if l then [ class_ " last_in_group" ] else [] + ] + in th_ (concat $ reverse a) (toHtml v) + cell (w,Val h l v) = + let a = [ [ class_ "kvitable_td" ] + , if h == 1 then [] + else [ rowspan_ $ T.pack $ show h ] + , if w == 1 then [] + else [ colspan_ $ T.pack $ show w + , class_ " multicol" ] + , if l then [ class_ " last_in_group" ] else [] + ] + in td_ (concat $ reverse a) (toHtml v) + labelMark = toHtmlRaw (" ←" :: Text) + labelHtml = th_ [ class_ "rightlabel kvitable_th" ] . + (labelMark <>) . + toHtml + in do mapM_ cell $ L.filter ((/= 0) . fst) $ + zip (drop excessColCnt cols) vals + maybe mempty labelHtml mbRLabel + + +---------------------------------------------------------------------- + +data HeaderLine = HdrLine FmtLine HdrVals Trailer +type HdrVals = [FmtVal] +type Trailer = Maybe Text + +instance Semigroup HeaderLine where + (HdrLine fmt1 hv1 t1) <> (HdrLine fmt2 hv2 _) = + HdrLine (fmt1 <> fmt2) (hv1 <> hv2) t1 + +hdrFmt :: HeaderLine -> FmtLine +hdrFmt (HdrLine fmt _ _) = fmt + +renderHdrs :: PP.Pretty v + => RenderConfig -> KVITable v -> [Key] + -> ( FmtLine, Html () ) +renderHdrs cfg t keys = + ( rowfmt, sequence_ [ fmtRender fmt hdrvals trailer + | (HdrLine fmt hdrvals trailer) <- hrows + ]) + where + (hrows, rowfmt) = hdrstep cfg t keys + +hdrstep :: PP.Pretty v + => RenderConfig -> KVITable v -> [Key] -> ([HeaderLine], FmtLine) +hdrstep _cfg t [] = + ( [ HdrLine (FmtLine [1]) [Hdr 1 False $ t ^. valueColName] Nothing ] + , FmtLine [1] + ) +hdrstep cfg t (key:keys) = + if colStackAt cfg == Just key + then hdrvalstep cfg t [] (key:keys) -- switch to column stacking mode + else + let (nexthdrs, lowestfmt) = hdrstep cfg t keys + (HdrLine fmt vals tr) = head nexthdrs -- safe: there were keys + fmt' = fmtAddColLeft 1 fmt + val = Hdr (length nexthdrs) False key + in ( (HdrLine fmt' (val : vals) tr) : tail nexthdrs + , fmtAddColLeft 1 lowestfmt + ) + +hdrvalstep :: PP.Pretty v + => RenderConfig -> KVITable v -> KeySpec -> [Key] + -> ([HeaderLine], FmtLine) +hdrvalstep _ _ _ [] = error "HTML hdrvalstep with empty keys after matching colStackAt -- impossible" +hdrvalstep cfg t steppath (key:[]) = + let titles = ordering $ fromMaybe [] $ L.lookup key $ t ^. keyVals + ordering = if sortKeyVals cfg then sortWithNums else id + cvalWidths kv = fmap (length . show . PP.pretty . snd) $ + L.filter ((L.isSuffixOf (steppath <> [(key, kv)])) . fst) $ + toList t + cwidth c = if and [ hideBlankCols cfg + , 0 == (sum $ cvalWidths c) ] + then 0 + else 1 + fmt = FmtLine $ fmap cwidth titles + in ( [ HdrLine fmt (Hdr 1 False <$> titles) (Just key) ], fmt) +hdrvalstep cfg t steppath (key:keys) = + let titles = ordering $ fromMaybe [] $ L.lookup key $ t ^. keyVals + ordering = if sortKeyVals cfg then sortWithNums else id + subhdrsV v = hdrvalstep cfg t (steppath <> [(key,v)]) keys + subTtlHdrs :: [ ([HeaderLine], FmtLine) ] + subTtlHdrs = subhdrsV <$> titles + subhdrs = if hideBlankCols cfg + then subTtlHdrs + else L.replicate (length titles) $ head subTtlHdrs + subhdr_rollup = joinHdrs <$> L.transpose (fst <$> subhdrs) + joinHdrs hl = foldl (<>) (head hl) (tail hl) + superFmt sub = let FmtLine subcols = hdrFmt $ last $ fst sub + in if sum subcols == 0 + then 0 + else length $ L.filter (/= 0) subcols + topfmt = FmtLine (superFmt <$> subhdrs) + tophdr = HdrLine topfmt (Hdr 1 False <$> titles) $ Just key + in ( tophdr : subhdr_rollup, F.fold (snd <$> subTtlHdrs)) + +---------------------------------------------------------------------- + +renderSeq :: PP.Pretty v + => RenderConfig -> FmtLine -> [Key] -> KVITable v -> Html () +renderSeq cfg fmt keys t = + mapM_ (flip (fmtRender fmt) Nothing) $ htmlRows keys [] + where + mkVal = Val 1 False . T.pack . show . PP.pretty + htmlRows :: [Key] -> KeySpec -> [ [FmtVal] ] + htmlRows [] path = + let v = lookup path t + skip = case v of + Nothing -> hideBlankRows cfg + Just _ -> False + row = maybe (Val 1 False "") mkVal v + in if skip then [] else [ [row] ] + htmlRows (key:kseq) path + | colStackAt cfg == Just key = + let filterOrDefaultBlankRows = + fmap (fmap (maybe (Val 1 False "") id)) . + if hideBlankRows cfg + then L.filter (not . all isNothing) + else id + in filterOrDefaultBlankRows $ + [ multivalRows (key:kseq) path ] + | otherwise = + let keyvals = ordering $ fromMaybe [] $ L.lookup key $ t ^. keyVals + ordering = if sortKeyVals cfg then sortWithNums else id + subrows keyval = htmlRows kseq $ path <> [(key,keyval)] + endOfGroup = key `elem` rowGroup cfg + addSubrows ret keyval = + let sr = subrows keyval + in ret <> (fst $ + foldl (leftAdd (length sr)) ([],Just keyval) $ + reverse $ zip (endOfGroup: L.repeat False) $ reverse sr) + leftAdd nrows (acc,mb'kv) (endGrp, subrow) = + let sr = setValGrouping endGrp <$> subrow + setValGrouping g (Val h g' v) = Val h (g || g') v + setValGrouping g (Hdr h g' v) = Hdr h (g || g') v + in ( acc <> [ (case mb'kv of + Nothing -> sr + Just kv -> let w = if rowRepeat cfg + then 1 + else nrows + in Hdr w endOfGroup kv : sr + ) ] + , if rowRepeat cfg then mb'kv else Nothing) + in foldl addSubrows [] keyvals + + + multivalRows [] _ = error "HTML multivalRows cannot be called with no keys!" + multivalRows (key:[]) path = + let keyvals = ordering $ fromMaybe [] $ L.lookup key $ t ^. keyVals + ordering = if sortKeyVals cfg then sortWithNums else id + in (\v -> mkVal <$> lookup (path <> [(key,v)]) t) <$> keyvals + multivalRows (key:kseq) path = + let keyvals = ordering $ fromMaybe [] $ L.lookup key $ t ^. keyVals + ordering = if sortKeyVals cfg then sortWithNums else id + in concatMap (\v -> multivalRows kseq (path <> [(key,v)])) keyvals diff --git a/test/AsciiRenderTests.hs b/test/AsciiRenderTests.hs new file mode 100644 --- /dev/null +++ b/test/AsciiRenderTests.hs @@ -0,0 +1,832 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} + +module AsciiRenderTests where + +import Control.Monad ( unless ) +import Data.Text ( Text ) +import qualified Data.Text as T +import Lens.Micro ( (^.), (.~), (%~), (&) ) +import Test.Tasty +import Test.Tasty.HUnit + +import SampleTables +import TestQQDefs + +import qualified Data.KVITable as KVI +import qualified Data.KVITable.Render as KTR +import qualified Data.KVITable.Render.ASCII as KTRA + + +cmpTables :: Text -> Text -> Text -> IO () +cmpTables nm actual expected = + unless (expected == actual) $ do + let dl (e,a) = if e == a then db e else de " ↱" e <> "\n " <> da " ↳" a + db b = "| > " <> b + de m e = "|" <> m <> "expect> " <> e + da m a = "|" <> m <> "actual> " <> a + el = T.lines expected + al = T.lines actual + addnum n l = let nt = T.pack (show n) + nl = T.length nt + in T.take (4 - nl) " " <> nt <> l + let details = ("MISMATCH between " <> + T.pack (show $ length el) <> " expected and " <> + T.pack (show $ length al) <> " actual for " <> nm) : + (fmap (uncurry addnum) $ + zip [1..] $ concat $ + -- Highly simplistic "diff" output assumes + -- correlated lines: added or removed lines just + -- cause everything to shown as different from that + -- point forward. + [ fmap dl $ zip el al + , fmap (de "∌ ") $ drop (length al) el + , fmap (da "∹ ") $ drop (length el) al + ]) + assertFailure $ T.unpack $ T.unlines details + + + +testAsciiRendering = + testGroup "ASCII rendering" $ + let kvi0 = mempty :: KVI.KVITable Text + cfg0 = KTR.defaultRenderConfig + cfgWBlankRows = cfg0 { KTR.hideBlankRows = False } + in + [ + testCase "empty table" $ + cmpTables "empty table" (KTRA.render cfg0 kvi0) [sq| +**** +| Value | ++-------+ +**** +|] + + , testCase "empty table with blanks" $ + cmpTables "empty table" (KTRA.render cfgWBlankRows kvi0) [sq| +**** +| Value | ++-------+ +| | +**** +|] + + , testCase "empty table with labels" $ + let kvi = mempty & KVI.keyVals @Float .~ [ ("foo", []), ("dog", []) ] + in cmpTables "empty table with labels" (KTRA.render cfg0 kvi) [sq| +**** +| foo | dog | Value | ++-----+-----+-------+ +****|] + + , testCase "add key" $ + let t0 = mempty & KVI.keyVals .~ [ ("foo", ["bar", "baz"]) ] :: KVI.KVITable Text + t1 = KVI.insert [ ("foo", "baz"), ("dog", "woof") ] "yo" $ + KVI.insert [ ("foo", "bar") ] "hi" + t0 + in do KVI.rows t1 @?= [ ([ "bar", "" ], "hi") + , ([ "baz", "woof"], "yo") + ] + cmpTables "add key" (KTRA.render cfg0 t1) [sq| +**** +| foo | dog | Value | ++-----+------+-------+ +| bar | | hi | +| baz | woof | yo | +****|] + + + , testCase "deep add" $ + let t0 = mempty + & KVI.keyVals .~ [ ("foo", ["bar", "baz"]) + , ("moon", ["beam", "pie"]) + ] + & KVI.valueColName .~ "says" + & KVI.keyValGen .~ const "?" + :: KVI.KVITable Text + t1 = KVI.insert [ ("foo", "Bill"), ("moon", "Ted"), ("dog", "arf arf") ] "Excellent!" $ + KVI.insert [ ("foo", "baz"), ("moon", "beam"), ("dog", "woof") ] "yo" $ + KVI.insert [ ("foo", "bar"), ("moon", "pie") ] "hi" + t0 + in cmpTables "add key" (KTRA.render cfg0 t1) [sq| +**** +| foo | moon | dog | says | ++------+------+---------+------------+ +| Bill | Ted | arf arf | Excellent! | +| bar | pie | ? | hi | +| baz | beam | woof | yo | +****|] + + , testCase "medium sized table render, sorted" $ + cmpTables "medium table" + (KTRA.render (cfg0 { KTR.sortKeyVals = True }) mediumKVI) [sq| +**** +| compiler | debug | optimization | Value | ++----------+-------+--------------+-------+ +| gcc7 | no | 0 | bad | +| gcc7 | no | 1 | good | +| gcc7 | yes | 0 | good | +| gcc7 | yes | 3 | ugly | +| gcc8 | yes | 0 | good | +| gcc8 | yes | 1 | bad | +| gcc8 | yes | 3 | true | +| clang6 | yes | 0 | ok | +| clang7 | no | 0 | good | +| clang7 | no | 1 | good | +| clang7 | no | 3 | good | +| clang7 | yes | 3 | good | +| clang10 | no | 3 | good | +| clang10 | yes | 3 | good | +****|] + + , testCase "medium sized table render, unsorted" $ + cmpTables "medium table" + (KTRA.render (cfg0 { KTR.sortKeyVals = False }) mediumKVI) [sq| +**** +| compiler | debug | optimization | Value | ++----------+-------+--------------+-------+ +| gcc7 | yes | 0 | good | +| gcc7 | yes | 3 | ugly | +| gcc7 | no | 0 | bad | +| gcc7 | no | 1 | good | +| gcc8 | yes | 0 | good | +| gcc8 | yes | 1 | bad | +| gcc8 | yes | 3 | true | +| clang6 | yes | 0 | ok | +| clang10 | yes | 3 | good | +| clang10 | no | 3 | good | +| clang7 | yes | 3 | good | +| clang7 | no | 0 | good | +| clang7 | no | 1 | good | +| clang7 | no | 3 | good | +****|] + + , testCase "medium table, sorted, blank, row skip, no repeats" $ + cmpTables "medium table" + (KTRA.render (cfg0 { KTR.sortKeyVals = True + , KTR.rowRepeat = False }) mediumKVI) [sq| +**** +| compiler | debug | optimization | Value | ++----------+-------+--------------+-------+ +| gcc7 | no | 0 | bad | +| | | 1 | good | +| | yes | 0 | good | +| | | 3 | ugly | +| gcc8 | yes | 0 | good | +| | | 1 | bad | +| | | 3 | true | +| clang6 | yes | 0 | ok | +| clang7 | no | 0 | good | +| | | 1 | good | +| | | 3 | good | +| | yes | 3 | good | +| clang10 | no | 3 | good | +| | yes | 3 | good | +****|] + + , testCase "medium table, sorted, blank row skip, no repeats, group unknown" $ + cmpTables "medium table s 0brow 0rep [unknown]" + (KTRA.render (cfg0 { KTR.sortKeyVals = True + , KTR.rowRepeat = False + , KTR.rowGroup = ["unknown"] + }) mediumKVI) [sq| +**** +| compiler | debug | optimization | Value | ++----------+-------+--------------+-------+ +| gcc7 | no | 0 | bad | +| | | 1 | good | +| | yes | 0 | good | +| | | 3 | ugly | +| gcc8 | yes | 0 | good | +| | | 1 | bad | +| | | 3 | true | +| clang6 | yes | 0 | ok | +| clang7 | no | 0 | good | +| | | 1 | good | +| | | 3 | good | +| | yes | 3 | good | +| clang10 | no | 3 | good | +| | yes | 3 | good | +****|] + + , testCase "medium table, sorted, blank row skip, no repeats, group compiler" $ + cmpTables "medium table s 0brow 0rep [unknown]" + (KTRA.render (cfg0 { KTR.sortKeyVals = True + , KTR.rowRepeat = False + , KTR.rowGroup = ["compiler"] + }) mediumKVI) [sq| +**** +| compiler | debug | optimization | Value | ++----------+-------+--------------+-------+ +| gcc7 | no | 0 | bad | +| | | 1 | good | +| | yes | 0 | good | +| | | 3 | ugly | ++----------+-------+--------------+-------+ +| gcc8 | yes | 0 | good | +| | | 1 | bad | +| | | 3 | true | ++----------+-------+--------------+-------+ +| clang6 | yes | 0 | ok | ++----------+-------+--------------+-------+ +| clang7 | no | 0 | good | +| | | 1 | good | +| | | 3 | good | +| | yes | 3 | good | ++----------+-------+--------------+-------+ +| clang10 | no | 3 | good | +| | yes | 3 | good | ++----------+-------+--------------+-------+ +****|] + + , testCase "medium table, sorted, blank row skip, no repeats, multi-group" $ + cmpTables "medium table s 0brow 0rep [compiler,debug]" + (KTRA.render (cfg0 { KTR.sortKeyVals = True + , KTR.rowRepeat = False + , KTR.rowGroup = ["unknown", "compiler", "unk", "debug", "huh"] + }) mediumKVI) [sq| +**** +| compiler | debug | optimization | Value | ++----------+-------+--------------+-------+ +| gcc7 | no | 0 | bad | +| | | 1 | good | +| |-------+--------------+-------+ +| | yes | 0 | good | +| | | 3 | ugly | ++----------+-------+--------------+-------+ +| gcc8 | yes | 0 | good | +| | | 1 | bad | +| | | 3 | true | ++----------+-------+--------------+-------+ +| clang6 | yes | 0 | ok | ++----------+-------+--------------+-------+ +| clang7 | no | 0 | good | +| | | 1 | good | +| | | 3 | good | +| |-------+--------------+-------+ +| | yes | 3 | good | ++----------+-------+--------------+-------+ +| clang10 | no | 3 | good | +| |-------+--------------+-------+ +| | yes | 3 | good | ++----------+-------+--------------+-------+ +****|] + + , testCase "medium table, sorted, blank" $ + cmpTables "medium table" + (KTRA.render (cfg0 { KTR.sortKeyVals = True + , KTR.hideBlankRows = False }) mediumKVI) [sq| +**** +| compiler | debug | optimization | Value | ++----------+-------+--------------+-------+ +| gcc7 | no | 0 | bad | +| gcc7 | no | 1 | good | +| gcc7 | no | 3 | | +| gcc7 | yes | 0 | good | +| gcc7 | yes | 1 | | +| gcc7 | yes | 3 | ugly | +| gcc8 | no | 0 | | +| gcc8 | no | 1 | | +| gcc8 | no | 3 | | +| gcc8 | yes | 0 | good | +| gcc8 | yes | 1 | bad | +| gcc8 | yes | 3 | true | +| clang6 | no | 0 | | +| clang6 | no | 1 | | +| clang6 | no | 3 | | +| clang6 | yes | 0 | ok | +| clang6 | yes | 1 | | +| clang6 | yes | 3 | | +| clang7 | no | 0 | good | +| clang7 | no | 1 | good | +| clang7 | no | 3 | good | +| clang7 | yes | 0 | | +| clang7 | yes | 1 | | +| clang7 | yes | 3 | good | +| clang10 | no | 0 | | +| clang10 | no | 1 | | +| clang10 | no | 3 | good | +| clang10 | yes | 0 | | +| clang10 | yes | 1 | | +| clang10 | yes | 3 | good | +****|] + + , testCase "medium sized table render, sorted, no blank, colstack unknown" $ + cmpTables "medium table s 0blnk colstk=unknown" + (KTRA.render (cfg0 { KTR.sortKeyVals = True + , KTR.colStackAt = Just "unknown" + }) mediumKVI) [sq| +**** +| compiler | debug | optimization | Value | ++----------+-------+--------------+-------+ +| gcc7 | no | 0 | bad | +| gcc7 | no | 1 | good | +| gcc7 | yes | 0 | good | +| gcc7 | yes | 3 | ugly | +| gcc8 | yes | 0 | good | +| gcc8 | yes | 1 | bad | +| gcc8 | yes | 3 | true | +| clang6 | yes | 0 | ok | +| clang7 | no | 0 | good | +| clang7 | no | 1 | good | +| clang7 | no | 3 | good | +| clang7 | yes | 3 | good | +| clang10 | no | 3 | good | +| clang10 | yes | 3 | good | +****|] + + , testCase "medium sized table render, sorted, !blank, colstk optimization" $ + cmpTables "medium table s 0blnk colstk=optimization" + (KTRA.render (cfg0 { KTR.sortKeyVals = True + , KTR.hideBlankRows = True + , KTR.colStackAt = Just "optimization" + }) mediumKVI) [sq| +**** +| compiler | debug | 0 | 1 | 3 | <- optimization ++----------+-------+------+------+------+ +| gcc7 | no | bad | good | | +| gcc7 | yes | good | | ugly | +| gcc8 | yes | good | bad | true | +| clang6 | yes | ok | | | +| clang7 | no | good | good | good | +| clang7 | yes | | | good | +| clang10 | no | | | good | +| clang10 | yes | | | good | +****|] + + , testCase "medium, sorted, !blank, !row rpt, rgrp compiler colstk optimization" $ + cmpTables "medium table s 0blnk colstk=optimization rowgrp=compiler" + (KTRA.render (cfg0 { KTR.sortKeyVals = True + , KTR.hideBlankRows = True + , KTR.colStackAt = Just "optimization" + , KTR.rowRepeat = False + , KTR.rowGroup = [ "compiler" ] + }) mediumKVI) [sq| +**** +| compiler | debug | 0 | 1 | 3 | <- optimization ++----------+-------+------+------+------+ +| gcc7 | no | bad | good | | +| | yes | good | | ugly | ++----------+-------+------+------+------+ +| gcc8 | yes | good | bad | true | ++----------+-------+------+------+------+ +| clang6 | yes | ok | | | ++----------+-------+------+------+------+ +| clang7 | no | good | good | good | +| | yes | | | good | ++----------+-------+------+------+------+ +| clang10 | no | | | good | +| | yes | | | good | ++----------+-------+------+------+------+ +****|] + + , testCase "medium sized table render, sorted, !blank, equisize, colstack debug" $ + cmpTables "medium table s 0blnk equisize colstk=debug" + (KTRA.render (cfg0 { KTR.sortKeyVals = True + , KTR.hideBlankRows = True + , KTR.equisizedCols = True + , KTR.colStackAt = Just "debug" + }) mediumKVI) [sq| +**** +| compiler | _______ no _______ | ______ yes _______ | <- debug +| | 0 | 1 | 3 | 0 | 1 | 3 | <- optimization ++----------+------+------+------+------+------+------+ +| gcc7 | bad | good | | good | | ugly | +| gcc8 | | | | good | bad | true | +| clang6 | | | | ok | | | +| clang7 | good | good | good | | | good | +| clang10 | | | good | | | good | +****|] + + , testCase "medium sized table render, sorted, !blank, fitsize, colstack debug" $ + cmpTables "medium table s 0blnk fitsize colstk=debug" + (KTRA.render (cfg0 { KTR.sortKeyVals = True + , KTR.hideBlankRows = True + , KTR.equisizedCols = False + , KTR.colStackAt = Just "debug" + }) mediumKVI) [sq| +**** +| compiler | _______ no _______ | ______ yes ______ | <- debug +| | 0 | 1 | 3 | 0 | 1 | 3 | <- optimization ++----------+------+------+------+------+-----+------+ +| gcc7 | bad | good | | good | | ugly | +| gcc8 | | | | good | bad | true | +| clang6 | | | | ok | | | +| clang7 | good | good | good | | | good | +| clang10 | | | good | | | good | +****|] + + , testCaseSteps "small table right aligned" $ \step -> + let tbl = foldl KVI.foldlInsert + (mempty & KVI.valueColName .~ "name" :: KVI.KVITable Text) inp + inp = [ ([("id", "2")], "Layla") + , ([("id", "3")], "Jack Gabriel") + , ([("id", "1")], "Sam") + ] + in do step "rows" -- generally in insert order (foldr pushes from end) + KVI.rows tbl @?= [ (["1"], "Sam") + , (["3"], "Jack Gabriel") + , (["2"], "Layla") + ] + step "ASCII rendering unsorted" + cmpTables "small table right aligned unsorted" + (KTRA.render (cfg0 { KTR.sortKeyVals = False }) tbl) [sq| +**** +| id | name | ++----+--------------+ +| 1 | Sam | +| 3 | Jack Gabriel | +| 2 | Layla | +****|] + step "ASCII rendering sorted" + cmpTables "small table right aligned sorted" + (KTRA.render (cfg0 { KTR.sortKeyVals = True }) tbl) [sq| +**** +| id | name | ++----+--------------+ +| 1 | Sam | +| 2 | Layla | +| 3 | Jack Gabriel | +****|] + + , testCase "small multi-column float value table rendering" $ + let tbl = foldl KVI.foldlInsert + (mempty & KVI.valueColName .~ "Annual Rainfall" :: KVI.KVITable Float) inp + inp = [ ([("City name", "Adelaide"), ("Area", "1295"), ("Population", "1158259")], 600.5) + , ([("City name", "Brisbane"), ("Area", "5905"), ("Population", "1857594")], 1146.4) + , ([("City name", "Darwin"), ("Area", "112"), ("Population", "120900")], 1714.7) + , ([("City name", "Hobart"), ("Area", "1357"), ("Population", "205556")], 619.5) + , ([("City name", "Melbourne"),("Area", "1566"), ("Population", "3806092")], 646.9) + , ([("City name", "Perth"), ("Area", "5386"), ("Population", "1554769")], 869.4) + , ([("City name", "Sydney"), ("Area", "2058"), ("Population", "4336374")], 1214.8) + ] + in cmpTables "small table float value table" + (KTRA.render (cfg0 { KTR.sortKeyVals = True }) tbl) [sq| +**** +| City name | Area | Population | Annual Rainfall | ++-----------+------+------------+-----------------+ +| Adelaide | 1295 | 1158259 | 600.5 | +| Brisbane | 5905 | 1857594 | 1146.4 | +| Darwin | 112 | 120900 | 1714.7 | +| Hobart | 1357 | 205556 | 619.5 | +| Melbourne | 1566 | 3806092 | 646.9 | +| Perth | 5386 | 1554769 | 869.4 | +| Sydney | 2058 | 4336374 | 1214.8 | +****|] + + , testCase "big table grouped sorted" $ + cmpTables "big table grouped sorted" + (KTRA.render (cfg0 { KTR.sortKeyVals = True + , KTR.rowRepeat = False + , KTR.rowGroup = [ "Location", "Biome", "Category" ] + }) zooTable2) + [uq_f|examples/zoo.md|] + + , testCase "big table grouped sorted no-subtype colstack" $ + let zt = KVI.fromList $ + foldl rmvSubtype [] $ + KVI.toList zooTable2 + rmvSubtype newl (keyspec, v) = + let ks = filter (("Subtype" /=) . fst) keyspec + in case lookup ks newl of + Nothing -> (ks,v) : newl + Just v' -> (ks, v' + v) : filter ((ks /=) . fst) newl + in cmpTables "big table grouped sorted no-subtype colstack" + (KTRA.render (cfg0 { KTR.sortKeyVals = True + , KTR.rowRepeat = False + , KTR.rowGroup = [ "Location", "Biome", "Category" ] + , KTR.colStackAt = Just "Name" + , KTR.equisizedCols = False + }) zt) + [uq2_f|examples/zoo.md|] + + , testCase "big table grouped sorted equisized" $ + cmpTables "big table grouped sorted equisized" + (KTRA.render (cfg0 { KTR.sortKeyVals = True + , KTR.rowRepeat = False + , KTR.hideBlankCols = False + , KTR.equisizedCols = True + , KTR.rowGroup = [ "Branch" ] + , KTR.colStackAt = Just "ghcver" + }) testedTable) + [sq| + # Note: no seplines under system because it wasn't included in the row_group +**** +| system | Branch | Strategy | ___ ghc844 ____ | ___ ghc865 ____ | ___ ghc882 ____ | ___ ghc890 ____ | <- ghcver +| | | | N | Y | N | Y | N | Y | N | Y | <- debug ++---------------+------------+------------+--------+--------+--------+--------+--------+--------+--------+--------+ +| x86_64-darwin | develop | HEADs | + | | | | | | | | +| |------------+------------+--------+--------+--------+--------+--------+--------+--------+--------+ +| x86_64-linux | PR-feature | HEADs | | | FAIL*2 | | FAIL*1 | | | | +| | | submodules | + | + | + | | FAIL*1 | | | | +| |------------+------------+--------+--------+--------+--------+--------+--------+--------+--------+ +| | develop | HEADs | + | + | + | | | | | | +| | | submodules | + | | | | FAIL*1 | | | | +| |------------+------------+--------+--------+--------+--------+--------+--------+--------+--------+ +| | master | HEADs | | FAIL*1 | FAIL*1 | | FAIL*1 | | | | +| | | submodules | + | FAIL*1 | FAIL*1 | | | | | | +| |------------+------------+--------+--------+--------+--------+--------+--------+--------+--------+ +****|] + + , testCase "big table grouped sorted fitsize colstack=ghcver" $ + cmpTables "big table grouped sorted fitsize colstack=ghcver" + (KTRA.render (cfg0 { KTR.sortKeyVals = True + , KTR.rowRepeat = False + , KTR.hideBlankCols = False + , KTR.equisizedCols = False + , KTR.rowGroup = [ "Branch" ] + , KTR.colStackAt = Just "ghcver" + }) testedTable) + [sq| + # Note: no seplines under system because it wasn't included in the row_group +**** +| system | Branch | Strategy | _ ghc844 _ | _ ghc865 _ | _ ghc882 _ | ghc890 | <- ghcver +| | | | N | Y | N | Y | N | Y | N | Y | <- debug ++---------------+------------+------------+---+--------+--------+---+--------+---+----+---+ +| x86_64-darwin | develop | HEADs | + | | | | | | | | +| |------------+------------+---+--------+--------+---+--------+---+----+---+ +| x86_64-linux | PR-feature | HEADs | | | FAIL*2 | | FAIL*1 | | | | +| | | submodules | + | + | + | | FAIL*1 | | | | +| |------------+------------+---+--------+--------+---+--------+---+----+---+ +| | develop | HEADs | + | + | + | | | | | | +| | | submodules | + | | | | FAIL*1 | | | | +| |------------+------------+---+--------+--------+---+--------+---+----+---+ +| | master | HEADs | | FAIL*1 | FAIL*1 | | FAIL*1 | | | | +| | | submodules | + | FAIL*1 | FAIL*1 | | | | | | +| |------------+------------+---+--------+--------+---+--------+---+----+---+ +****|] + + , testCase "big table grouped sorted fitsize colstack=Strategy" $ + cmpTables "big table grouped sorted fitsize colstack=Strategy" + (KTRA.render (cfg0 { KTR.sortKeyVals = True + , KTR.rowRepeat = False + , KTR.hideBlankCols = False + , KTR.equisizedCols = False + , KTR.rowGroup = [ "Branch" ] + , KTR.colStackAt = Just "Strategy" + }) testedTable) + [sq| + # Note: no seplines under system because it wasn't included in the row_group +**** +| system | Branch | ___________________ HEADs ___________________ | ________________ submodules _________________ | <- Strategy +| | | _ ghc844 _ | _ ghc865 _ | _ ghc882 _ | ghc890 | _ ghc844 _ | _ ghc865 _ | _ ghc882 _ | ghc890 | <- ghcver +| | | N | Y | N | Y | N | Y | N | Y | N | Y | N | Y | N | Y | N | Y | <- debug ++---------------+------------+---+--------+--------+---+--------+---+----+---+---+--------+--------+---+--------+---+----+---+ +| x86_64-darwin | develop | + | | | | | | | | | | | | | | | | +| |------------+---+--------+--------+---+--------+---+----+---+---+--------+--------+---+--------+---+----+---+ +| x86_64-linux | PR-feature | | | FAIL*2 | | FAIL*1 | | | | + | + | + | | FAIL*1 | | | | +| |------------+---+--------+--------+---+--------+---+----+---+---+--------+--------+---+--------+---+----+---+ +| | develop | + | + | + | | | | | | + | | | | FAIL*1 | | | | +| |------------+---+--------+--------+---+--------+---+----+---+---+--------+--------+---+--------+---+----+---+ +| | master | | FAIL*1 | FAIL*1 | | FAIL*1 | | | | + | FAIL*1 | FAIL*1 | | | | | | +| |------------+---+--------+--------+---+--------+---+----+---+---+--------+--------+---+--------+---+----+---+ +****|] + + , testCase "nested table hide=blankRows,blankCols colstack=ones" $ + cmpTables "nested table hide=blankRows,blankCols colstack=ones" + (KTRA.render (cfg0 { KTR.sortKeyVals = True + , KTR.rowRepeat = False + , KTR.hideBlankCols = True + , KTR.hideBlankRows = True + , KTR.equisizedCols = False + , KTR.colStackAt = Just "ones" + }) nestedTable) + [sq| +**** +| millions | thousands | hundreds | tens | 0 | 1 | <- ones ++----------+-----------+----------+------+------+-----+ +| 0 | 0 | 1 | 2 | even | odd | +| | | 2 | 2 | even | odd | +| | 1 | 1 | 2 | even | odd | +| | | 2 | 2 | even | odd | +| | 2 | 1 | 2 | even | odd | +| | | 2 | 2 | even | odd | +| 1 | 0 | 1 | 2 | even | odd | +| | | 2 | 2 | even | odd | +| | 1 | 1 | 2 | even | odd | +| | | 2 | 2 | even | odd | +| | 2 | 1 | 2 | even | odd | +| | | 2 | 2 | even | odd | +| 2 | 0 | 1 | 2 | even | odd | +| | | 2 | 2 | even | odd | +| | 1 | 1 | 2 | even | odd | +| | | 2 | 2 | even | odd | +| | 2 | 1 | 2 | even | odd | +| | | 2 | 2 | even | odd | +****|] + + , testCase "nested table colstack=tens" $ + cmpTables "nested table colstack=tens" + (KTRA.render (cfg0 { KTR.sortKeyVals = True + , KTR.rowRepeat = False + , KTR.hideBlankCols = True + , KTR.hideBlankRows = True + , KTR.equisizedCols = False + , KTR.colStackAt = Just "tens" + }) nestedTable) + -- Note: the nestedTable declares a KeyVal of 0 for each key; + -- without hideBlankCols true, this test would show a 0 value + -- column for the tens stacked column. + [sq| +**** +| millions | thousands | hundreds | ___ 2 ____ | <- tens +| | | | 0 | 1 | <- ones ++----------+-----------+----------+------+-----+ +| 0 | 0 | 1 | even | odd | +| | | 2 | even | odd | +| | 1 | 1 | even | odd | +| | | 2 | even | odd | +| | 2 | 1 | even | odd | +| | | 2 | even | odd | +| 1 | 0 | 1 | even | odd | +| | | 2 | even | odd | +| | 1 | 1 | even | odd | +| | | 2 | even | odd | +| | 2 | 1 | even | odd | +| | | 2 | even | odd | +| 2 | 0 | 1 | even | odd | +| | | 2 | even | odd | +| | 1 | 1 | even | odd | +| | | 2 | even | odd | +| | 2 | 1 | even | odd | +| | | 2 | even | odd | +****|] + + , testCase "nested table hide=blankCols,blankRows colstack=hundreds" $ + cmpTables "nested table hide-blankCols,blankRows colstack=hundreds" + (KTRA.render (cfg0 { KTR.sortKeyVals = True + , KTR.rowRepeat = False + , KTR.hideBlankCols = True + , KTR.hideBlankRows = True + , KTR.equisizedCols = False + , KTR.colStackAt = Just "hundreds" + }) nestedTable) + [uq_f|README.md|] + + , testCase "nested table hide=none colstack=hundreds" $ + cmpTables "nested table hide=none colstack=hundreds" + (KTRA.render (cfg0 { KTR.sortKeyVals = True + , KTR.rowRepeat = False + , KTR.hideBlankCols = False + , KTR.hideBlankRows = False + , KTR.equisizedCols = False + , KTR.colStackAt = Just "hundreds" + }) nestedTable) + [uq_f|examples/hundreds_all.md|] + + , testCase "nested table hide=none colstack=hundreds equisized" $ + cmpTables "nested table hide=none colstack=hundreds equisized" + (KTRA.render (cfg0 { KTR.sortKeyVals = True + , KTR.rowRepeat = False + , KTR.hideBlankCols = False + , KTR.hideBlankRows = False + , KTR.equisizedCols = True + , KTR.colStackAt = Just "hundreds" + }) nestedTable) + [uq2_f|examples/hundreds_all.md|] + + , testCase "nested table hideBlank=rol,col colstack=thousands" $ + cmpTables "nested table hideBlank=row,col colstack=thousands" + (KTRA.render (cfg0 { KTR.sortKeyVals = True + , KTR.rowRepeat = False + , KTR.hideBlankCols = True + , KTR.hideBlankRows = True + , KTR.equisizedCols = False + , KTR.colStackAt = Just "thousands" + }) nestedTable) + [uq2_f|README.md|] + + , testCase "nested table hideBlank=rol,col" $ + cmpTables "nested table hideBlank=row,col" + (KTRA.render (cfg0 { KTR.sortKeyVals = True + , KTR.rowRepeat = False + , KTR.hideBlankCols = True + , KTR.hideBlankRows = True + , KTR.equisizedCols = False + }) nestedTable) + [uq3_f|README.md|] + + , testCase "nested table hideBlank=none" $ + cmpTables "nested table hideBlank=none" + (KTRA.render (cfg0 { KTR.sortKeyVals = True + , KTR.rowRepeat = False + , KTR.hideBlankCols = False + , KTR.hideBlankRows = False + , KTR.equisizedCols = False + }) nestedTable) + [sq| +**** +| millions | thousands | hundreds | tens | ones | Value | ++----------+-----------+----------+------+------+-------+ +| 0 | 0 | 0 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | | +| | | | | 1 | | +| | | 1 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | even | +| | | | | 1 | odd | +| | | 2 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | even | +| | | | | 1 | odd | +| | 1 | 0 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | | +| | | | | 1 | | +| | | 1 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | even | +| | | | | 1 | odd | +| | | 2 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | even | +| | | | | 1 | odd | +| | 2 | 0 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | | +| | | | | 1 | | +| | | 1 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | even | +| | | | | 1 | odd | +| | | 2 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | even | +| | | | | 1 | odd | +| 1 | 0 | 0 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | | +| | | | | 1 | | +| | | 1 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | even | +| | | | | 1 | odd | +| | | 2 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | even | +| | | | | 1 | odd | +| | 1 | 0 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | | +| | | | | 1 | | +| | | 1 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | even | +| | | | | 1 | odd | +| | | 2 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | even | +| | | | | 1 | odd | +| | 2 | 0 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | | +| | | | | 1 | | +| | | 1 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | even | +| | | | | 1 | odd | +| | | 2 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | even | +| | | | | 1 | odd | +| 2 | 0 | 0 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | | +| | | | | 1 | | +| | | 1 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | even | +| | | | | 1 | odd | +| | | 2 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | even | +| | | | | 1 | odd | +| | 1 | 0 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | | +| | | | | 1 | | +| | | 1 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | even | +| | | | | 1 | odd | +| | | 2 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | even | +| | | | | 1 | odd | +| | 2 | 0 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | | +| | | | | 1 | | +| | | 1 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | even | +| | | | | 1 | odd | +| | | 2 | 0 | 0 | | +| | | | | 1 | | +| | | | 2 | 0 | even | +| | | | | 1 | odd | +****|] + + ] diff --git a/test/HTMLRenderTests.hs b/test/HTMLRenderTests.hs new file mode 100644 --- /dev/null +++ b/test/HTMLRenderTests.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} + +module HTMLRenderTests where + +import Control.Monad ( unless ) +import qualified Data.List as L +import Data.Text ( Text ) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Lens.Micro ( (^.), (.~), (%~), (&) ) +import Test.Tasty +import Test.Tasty.HUnit +import Text.HTML.Parser ( parseTokens, renderToken + , canonicalizeTokens + , Token( TagOpen, TagSelfClose ) ) + +import SampleTables +import TestQQDefs + +import qualified Data.KVITable as KVI +import qualified Data.KVITable.Render as KTR +import qualified Data.KVITable.Render.HTML as KTRH + + +cmpTables :: Text -> Text -> Text -> IO () +cmpTables nm actual expected = do + let expH = normalize $ parseTokens $ T.concat $ fmap T.strip $ T.lines expected + actH = normalize $ parseTokens actual + normalize = fmap sortAttrs . canonicalizeTokens + sortAttrs (TagOpen n a) = TagOpen n $ L.sort a + sortAttrs (TagSelfClose n a) = TagSelfClose n $ L.sort a + sortAttrs t = t + unless (expH == actH) $ do + let dl (e,a) = if e == a then db e else de " ↱" e <> "\n " <> da " ↳" a + db b = "| > " <> b + de m e = "|" <> m <> "expect> " <> e + da m a = "|" <> m <> "actual> " <> a + el = fmap (TL.toStrict . renderToken) expH + al = fmap (TL.toStrict . renderToken) actH + addnum n l = let nt = T.pack (show n) + nl = T.length nt + in T.take (4 - nl) " " <> nt <> l + let details = ("MISMATCH between " <> + T.pack (show $ length el) <> " expected and " <> + T.pack (show $ length al) <> " actual for " <> nm) : + (fmap (uncurry addnum) $ + zip [1..] $ concat $ + -- Highly simplistic "diff" output assumes + -- correlated lines: added or removed lines just + -- cause everything to shown as different from that + -- point forward. + [ fmap dl $ zip el al + , fmap (de "∌ ") $ drop (length al) el + , fmap (da "∹ ") $ drop (length el) al + ]) + assertFailure $ T.unpack $ T.unlines details + + +testHTMLRendering = + testGroup "HTML rendering" $ + let kvi0 = mempty :: KVI.KVITable Text + cfg0 = KTR.defaultRenderConfig + cfgWBlankRows = cfg0 { KTR.hideBlankRows = False } + in + [ + testCase "empty table, hide blank" $ + cmpTables "empty table, hide blank" + (KTRH.render cfg0 kvi0) [sq| +**** +
+ + + + + +
Value
+**** +|] + + , testCase "empty table, show blank" $ + cmpTables "empty table, show blank" + (KTRH.render cfgWBlankRows kvi0) [sq| +**** + + + + + + + + + +
Value
+**** +|] + + , testCase "empty table with labels" $ + let kvi = mempty & KVI.keyVals @Float .~ [ ("foo", []), ("dog", []) ] + in cmpTables "empty table with labels" (KTRH.render cfg0 kvi) [sq| +**** + + + + + + + + + + +
foodogValue
+**** +|] + + , testCase "nested table hideBlank=rows,cols, fitted, colstack=hundreds" $ + cmpTables "nested table hideBlank=rows,cols, fitted, colstack=hundreds" + (KTRH.render (cfg0 { KTR.sortKeyVals = True + , KTR.rowRepeat = False + , KTR.hideBlankCols = True + , KTR.hideBlankRows = True + , KTR.equisizedCols = False + , KTR.colStackAt = Just "hundreds" + }) nestedTable) + [sq_f|README.md|] + + , testCase "nested table hide=none, fitted, colstack=hundreds" $ + cmpTables "nested table hide=none, fitted, colstack=hundreds" + (KTRH.render (cfg0 { KTR.sortKeyVals = True + , KTR.rowRepeat = False + , KTR.hideBlankCols = False + , KTR.hideBlankRows = False + , KTR.equisizedCols = False + , KTR.colStackAt = Just "hundreds" + }) nestedTable) + [sq_f|examples/hundreds_all.md|] + + , testCase "nested table hideBlank=rol,col colstack=thousands" $ + cmpTables "nested table hideBlank=row,col colstack=thousands" + (KTRH.render (cfg0 { KTR.sortKeyVals = True + , KTR.rowRepeat = False + , KTR.hideBlankCols = True + , KTR.hideBlankRows = True + , KTR.equisizedCols = False + , KTR.colStackAt = Just "thousands" + }) nestedTable) + [sq2_f|README.md|] + + , testCase "nested table hideBlank=rol,col" $ + cmpTables "nested table hideBlank=row,col" + (KTRH.render (cfg0 { KTR.sortKeyVals = True + , KTR.rowRepeat = False + , KTR.hideBlankCols = True + , KTR.hideBlankRows = True + , KTR.equisizedCols = False + + }) nestedTable) + [sq3_f|README.md|] + + , testCase "big table grouped sorted" $ + cmpTables "big table grouped sorted" + (KTRH.render (cfg0 { KTR.sortKeyVals = True + , KTR.rowRepeat = False + , KTR.rowGroup = [ "Location", "Biome", "Category" ] + }) zooTable2) + [sq_f|examples/zoo.md|] + + , testCase "big table grouped sorted no-subtype colstack" $ + let zt = KVI.fromList $ + foldl rmvSubtype [] $ + KVI.toList zooTable2 + rmvSubtype newl (keyspec, v) = + let ks = filter (("Subtype" /=) . fst) keyspec + in case lookup ks newl of + Nothing -> (ks,v) : newl + Just v' -> (ks, v' + v) : filter ((ks /=) . fst) newl + in cmpTables "big table grouped sorted no-subtype colstack" + (KTRH.render (cfg0 { KTR.sortKeyVals = True + , KTR.rowRepeat = False + , KTR.rowGroup = [ "Location", "Biome", "Category" ] + , KTR.colStackAt = Just "Name" + , KTR.equisizedCols = False + }) zt) + [sq2_f|examples/zoo.md|] + + + ] diff --git a/test/SampleTables.hs b/test/SampleTables.hs new file mode 100644 --- /dev/null +++ b/test/SampleTables.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE OverloadedStrings #-} + +module SampleTables where + +import Data.KVITable +import Data.Text ( Text ) +import qualified Data.Text as T +import Lens.Micro ( (^.), (.~), (%~), (&) ) + + +listing1 :: [ ( [(Key, KeyVal)], Text ) ] +listing1 = + [ ( [("foo", "bar"), ("moo", "cow")], "one" ) + , ( [("moo", "cow"), ("foo", "bar"), ("goose", "honk")], "two" ) + , ( [("moo", "cow")], "three" ) + , ( [("foo", "baz"), ("moo", "cow")], "four") + ] +kvi1 = fromList listing1 +kvi1_1 = fromList $ take 2 listing1 +kvi1_2 = fromList $ drop 2 listing1 + +mediumKVI = foldl foldlInsert + (mempty + & keyVals .~ [ ("compiler", [ "gcc7", "gcc8", "clang6", "clang10", "clang7" ]) + , ("debug", [ "yes", "no" ]) + , ("optimization", [ "0", "1", "3" ]) + ]) + [ ([("compiler", "gcc7"), ("debug", "yes"), ("optimization", "0")], "good") + , ([("compiler", "gcc7"), ("debug", "no" ), ("optimization", "0")], "bad") + , ([("compiler", "gcc7"), ("debug", "yes"), ("optimization", "3")], "ugly") + , ([("compiler", "gcc8"), ("debug", "yes"), ("optimization", "0")], "good") + , ([("compiler", "clang6"), ("debug", "yes"), ("optimization", "0")], "ok") + , ([("compiler", "clang7"), ("debug", "no"), ("optimization", "1")], "good") + , ([("compiler", "clang7"), ("debug", "no"), ("optimization", "3")], "good") + , ([("compiler", "clang7"), ("debug", "yes"), ("optimization", "3")], "good") + , ([("compiler", "clang10"), ("debug", "no"), ("optimization", "3")], "good") + , ([("compiler", "clang10"), ("debug", "yes"), ("optimization", "3")], "good") + , ([("compiler", "gcc8"), ("debug", "yes"), ("optimization", "3")], "true") + , ([("compiler", "gcc8"), ("debug", "yes"), ("optimization", "1")], "bad") + , ([("compiler", "clang7"), ("debug", "no"), ("optimization", "0")], "good") + , ([("compiler", "gcc7"), ("debug", "no"), ("optimization", "1")], "good") + ] + +-- this table has floating values and keys with spaces +ptable = foldl foldlInsert + (mempty & valueColName .~ "Annual Rainfall") + [ ([("City name", "Adelaide"), ("Area", "1295"), ("Population", "1158259")], 600.5) + , ([("City name", "Brisbane"), ("Area", "5905"), ("Population", "1857594")], 1146.4) + , ([("City name", "Darwin"), ("Area", "112"), ("Population", "120900")], 1714.7) + , ([("City name", "Hobart"), ("Area", "1357"), ("Population", "205556")], 619.5) + , ([("City name", "Melbourne"), ("Area", "1566"), ("Population", "3806092")], 646.9) + , ([("City name", "Perty"), ("Area", "5386"), ("Population", "1554769")], 869.4) + , ([("City name", "Sydney"), ("Area", "2058"), ("Population", "4336374")], 1214.8) + ] + +-- big and complicated +zooTable = foldl foldlInsert + (mempty & valueColName .~ "Count" + & keyVals .~ [ ("Location", ["San Diego", "LA", "Miami", "New York"]) + , ("Biome", ["Savannah", "Jungle", "Polar"]) + , ("Category", ["Animal", "Reptile", "Bird"]) + , ("Diet", ["Herbivore", "Carnivore"]) + , ("Name", []) + ]) + [ ([ ("Diet", "Carnivore") + , ("Category", "Animal") + , ("Biome", "Savannah") + , ("Name", "Lion") + , ("Location", "New York")], 3) + , ([ ("Diet", "Carnivore") + , ("Category", "Animal") + , ("Biome", "Savannah") + , ("Name", "Lion") + , ("Location", "Miami")], 2) + , ([ ("Diet", "Carnivore") + , ("Category", "Animal") + , ("Biome", "Savannah") + , ("Name", "Lion") + , ("Location", "LA")], 4) + , ([ ("Diet", "Carnivore") + , ("Category", "Animal") + , ("Biome", "Savannah") + , ("Name", "Lion") + , ("Location", "San Diego")], 8) + , ([ ("Location", "LA") + , ("Biome", "Savannah") + , ("Category", "Animal") + , ("Name", "Giraffe") + , ("Diet", "Herbivore")], 2) + , ([ ("Location", "LA") + , ("Biome", "Jungle") + , ("Category", "Animal") + , ("Name", "Hippo") + , ("Diet", "Herbivore")], 1) + , ([ ("Location", "LA") + , ("Biome", "Savannah") + , ("Category", "Animal") + , ("Diet", "Herbivore") + , ("Name", "Rhino")], 3) + , ([ ("Location", "Miami") + , ("Biome", "Polar") + , ("Category", "Bird") + , ("Diet", "Carnivore") + , ("Subtype", "Gentoo") -- new key + , ("Name", "Penguin")], 20) + , ([ ("Location", "San Diego") + , ("Biome", "Polar") + , ("Category", "Bird") + , ("Diet", "Carnivore") + , ("Subtype", "Emperor") + , ("Name", "Penguin")], 8) + , ([ ("Location", "San Diego") + , ("Biome", "Polar") + , ("Category", "Bird") + , ("Diet", "Carnivore") + , ("Subtype", "Gentoo") + , ("Name", "Penguin")], 2) + , ([ ("Location", "Miami") + , ("Biome", "Savannah") + , ("Category", "Animal") + , ("Diet", "Herbivore") + , ("Name", "Giraffe") + , ("Subtype", "Reticulated")], 3) + ] +zooTable2 = insert [ ("Location", "San Diego"), ("Biome", "Plains") + , ("Category", "Animal"), ("Subtype", "Black") + , ("Name", "Bear"), ("Diet", "Omnivore") ] 1 $ + insert [ ("Location", "San Diego"), ("Biome", "Plains") + , ("Category", "Animal"), ("Subtype", "Brown") + , ("Name", "Bear"), ("Diet", "Omnivore") ] 1 $ + insert [ ("Location", "San Diego"), ("Biome", "Jungle") + , ("Category", "Animal"), ("Subtype", "Sun") + , ("Name", "Bear"), ("Diet", "Omnivore") ] 1 $ + insert [ ("Location", "San Diego"), ("Biome", "Polar") + , ("Category", "Animal"), ("Subtype", "Polar") + , ("Name", "Bear"), ("Diet", "Omnivore") ] 1 $ + adjust succ ([ ("Category", "Animal") + , ("Diet", "Carnivore") + , ("Biome", "Savannah") + , ("Location", "San Diego") + , ("Name", "Lion")]) + zooTable + +testedTable = foldl foldlInsert + (mempty + & keyVals .~ [ ("system", ["x86_64-linux", "x86_64-darwin"]) + , ("Branch", ["master", "develop", "PR-feature"]) + , ("Strategy", ["submodules", "HEADs"]) + , ("ghcver", ["ghc844", "ghc865", "ghc882", "ghc890"]) + , ("debug", ["Y", "N"]) + ]) + $ let ls g b d v = ([ ("system", "x86_64-linux") + , ("Strategy", "submodules") + , ("ghcver", g), ("Branch", b) + , ("debug", d) ], v) + lH g b d v = ([ ("system", "x86_64-linux") + , ("Strategy", "HEADs") + , ("ghcver", g), ("Branch", b) + , ("debug", d) ], v) + ms g b d v = ([ ("system", "x86_64-darwin") + , ("Strategy", "submodules") + , ("ghcver", g), ("Branch", b) + , ("debug", d) ], v) + mH g b d v = ([ ("system", "x86_64-darwin") + , ("Strategy", "HEADs") + , ("ghcver", g), ("Branch", b) + , ("debug", d) ], v) + in [ ls "ghc844" "PR-feature" "Y" "+" + , ls "ghc844" "PR-feature" "N" "+" + , lH "ghc865" "PR-feature" "N" "FAIL*2" + , ls "ghc882" "develop" "N" "FAIL*1" + , lH "ghc865" "develop" "N" "+" + , ls "ghc844" "master" "Y" "FAIL*1" + , ls "ghc844" "master" "N" "+" + , lH "ghc844" "master" "Y" "FAIL*1" + , lH "ghc865" "master" "N" "FAIL*1" + , lH "ghc882" "master" "N" "FAIL*1" + , ls "ghc865" "master" "N" "FAIL*1" + , lH "ghc844" "develop" "Y" "+" + , lH "ghc844" "develop" "N" "+" + , lH "ghc882" "PR-feature" "N" "FAIL*1" + , ls "ghc882" "PR-feature" "N" "FAIL*1" + , ls "ghc865" "PR-feature" "N" "+" + , ls "ghc844" "develop" "N" "+" + , lH "ghc844" "develop" "Y" "+" + , mH "ghc844" "develop" "N" "+" + ] + +nestedTable = foldl foldlInsert + (mempty + & keyVals .~ [ ("millions", ["0"]) + , ("thousands", ["0"]) + , ("hundreds", ["0"]) + , ("tens", ["0"]) + , ("ones", ["0"]) + ] + ) + [ let keyvals = [("millions", T.pack $ show m) + ,("thousands", T.pack $ show t) + ,("hundreds", T.pack $ show h) + ,("tens", T.pack $ show d) + ,("ones", T.pack $ show o)] + value = if (o `rem` 2) == 1 then "odd" else "even" + in (keyvals, value) + | m <- [0..2 :: Int] + , t <- [0..2 :: Int] + , h <- [1..2 :: Int] + , d <- [2..2 :: Int] + , o <- [0..1 :: Int] + ] diff --git a/test/TestMain.hs b/test/TestMain.hs new file mode 100644 --- /dev/null +++ b/test/TestMain.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Data.List ( sort ) +import Data.Maybe ( catMaybes ) +import Data.Text ( Text ) +import qualified Data.Text as T +import Lens.Micro ( (^.), (.~), (%~), (&) ) +import Test.Tasty +import Test.Tasty.HUnit + +import Data.KVITable + +import Prelude hiding ( filter, lookup ) + +import AsciiRenderTests +import HTMLRenderTests +import SampleTables + + +main :: IO () +main = defaultMain $ + testGroup "kvitable tests" $ + let kvi0 = mempty :: KVITable Text + in + [ + testCase "empty table" $ (mempty :: KVITable Bool) @=? (mempty :: KVITable Bool) + + , testCase "to and from" $ length listing1 @=? length (toList kvi1) + + , testCase "length" $ length listing1 @=? length kvi1 + + , testCase "mappable" $ + sum (snd <$> (fmap T.length) <$> listing1) @=? + sum (snd <$> toList (T.length <$> kvi1)) + + , testCase "traversable" $ + Just (sort $ snd <$> listing1) @=? + sort . fmap snd . toList <$> (traverse Just kvi1) + + , testCaseSteps "semigroup" $ \step -> + do step "empty to full" + mempty <> kvi1 @?= kvi1 + step "full to empty" + kvi1 <> mempty @?= kvi1 + step "idempotent" + kvi1 <> kvi1 @?= kvi1 + + step "join parts" + kvi1_1 <> kvi1_2 @?= kvi1 -- happens to be the right order + + -- note: it is *not* the case that + -- + -- > kvi1_2 <> kvi1_1 == kvi1 + -- + -- because the keyvals from a semigroup operation are + -- built dynamically and this particular kvi1_1 / + -- kvi1_2 will result in a different key order in + -- reverse. However, specifying the keyVals + -- explicitly can eliminate key detection ordering concerns. + + step "keyed" + let keyed = mempty & keyVals .~ [ ("foo", ["baz", "", "bar"]) + , ("moo", ["cow"]) + , ("goose", ["honk", ""]) + ] + keyed <> kvi1_1 <> kvi1_2 @?= kvi1 + + , testCase "empty lookup fails" $ + Nothing @=? lookup [("foo", "bar"), ("moo", "cow")] (mempty :: KVITable Bool) + + , testCase "regular lookup" $ + Just "one" @=? lookup [("foo", "bar"), ("moo", "cow")] kvi1 + + , testCase "add to empty table" $ + let keyvals = [ ("foo", "bar"), ("moo", "cow") ] + in [ (keyvals, "hi") ] @=? toList (insert keyvals "hi" kvi0) + + , testCase "getRows on empty table" $ [] @=? rows kvi0 + + , testCase "rows in simple table" $ + let keyvals = [ ("foo", "bar"), ("moo", "cow") ] + in [ (["bar", "cow"], "hi") ] @=? rows (insert keyvals "hi" kvi0) + + , testCaseSteps "non-leaf kvitable insert uses default key value" $ \step -> + do let keyvals = [ ("foo", "bar"), ("moo", "cow") ] + t1 = insert keyvals "hi" kvi0 + + step "at start" + let t2 = insert [ ("moo", "dog") ] "oops" t1 + rows t2 @?= [ ([ "", "dog" ], "oops") + , ([ "bar", "cow" ], "hi") + ] + + step "at end" + let t3 = insert [ ("foo", "dog") ] "oops" t1 + rows t3 @?= [ ([ "dog", "" ], "oops") + , ([ "bar", "cow" ], "hi") + ] + + step "in middle" + let keyvals' = [ ("foo", "bar"), ("moo", "cow"), ("oink", "pig") ] + t1' = insert keyvals' "hi" kvi0 + t4 = insert [ ("foo", "baz"), ("oink", "hog") ] "oops" t1' + rows t4 @?= [ ([ "baz", "", "hog" ], "oops") + , ([ "bar", "cow", "pig" ], "hi") + ] + + , testCaseSteps "valueColName" $ \step -> + do step "fetch" + "Value" @=? kvi1 ^. valueColName + step "set" + "says" @=? (kvi1 & valueColName .~ "says") ^. valueColName + step "update" + "says Value" @=? (kvi1 & valueColName %~ ("says " <>)) ^. valueColName + + , testCase "keyVals fetch" $ [ ("foo", ["baz", "", "bar"]) + , ("moo", ["cow"]) + , ("goose", ["honk", ""]) + ] @=? kvi1 ^. keyVals + + , testCaseSteps "lookup" $ \step -> + do step "valid #1" + Just "three" @=? lookup [("moo", "cow")] kvi1 + step "valid #2" + Just "two" @=? lookup [("goose", "honk"), ("moo", "cow"), ("foo", "bar")] kvi1 + step "valid #3" + Just "four" @=? lookup [("moo", "cow"), ("foo", "baz")] kvi1 + step "valid #4" + Just "one" @=? lookup [("moo", "cow"), ("foo", "bar")] kvi1 + step "valid with dups" + -- Note: ok to duplicate key values with identical entries + Just "one" @=? lookup [("moo", "cow"), ("foo", "bar"), ("moo", "cow")] kvi1 + step "invalid #1" + Nothing @=? lookup [("moo", "bar")] kvi1 + step "invalid #2" + Nothing @=? lookup [("foo", "moo"), ("cow", "moo")] kvi1 + step "invalid #3" + Nothing @=? lookup [] kvi1 + + , testCase "multiply-specified lookups" $ + -- one of these will work, one will fail, but it's + -- indeterminate which one. This is not a recommended + -- usage, but rather than waste computational resources + -- to prevent it, this is simply documenting this as a + -- known behavior and users are discouraged from using + -- it. + 1 @=? (length $ catMaybes [ lookup [("moo", "sheep"), ("foo", "bar"), ("moo", "cow")] kvi1 + , lookup [("moo", "cow"), ("foo", "bar"), ("moo", "sheep")] kvi1 + ]) + + , testCase "deep add" $ + let t0 = mempty + & keyVals .~ [ ("foo", ["bar", "baz"]) + , ("moon", ["beam", "pie"]) + ] + & valueColName .~ "says" + t1 = insert [ ("foo", "Bill"), ("moon", "Ted"), ("dog", "arf arf") ] "Excellent!" $ + insert [ ("foo", "baz"), ("moon", "beam"), ("dog", "woof") ] "yo" $ + insert [ ("foo", "bar"), ("moon", "pie") ] "hi" + t0 + in rows t1 @?= [ ([ "Bill", "Ted", "arf arf" ], "Excellent!") + , ([ "bar", "pie", "" ], "hi") + , ([ "baz", "beam", "woof"], "yo") + ] + + , testCase "medium sized table rows" $ + rows mediumKVI @?= + [ ([ "gcc7", "yes", "0"], "good" ) + , ([ "gcc7", "yes", "3"], "ugly" ) + , ([ "gcc7", "no", "0"], "bad" ) + , ([ "gcc7", "no", "1"], "good" ) + , ([ "gcc8", "yes", "0"], "good" ) + , ([ "gcc8", "yes", "1"], "bad" ) + , ([ "gcc8", "yes", "3"], "true" ) + , ([ "clang6", "yes", "0"], "ok" ) + , ([ "clang10", "yes", "3"], "good" ) + , ([ "clang10", "no", "3"], "good" ) + , ([ "clang7", "yes", "3"], "good" ) + , ([ "clang7", "no", "0"], "good" ) + , ([ "clang7", "no", "1"], "good" ) + , ([ "clang7", "no", "3"], "good" ) + ] + + , testCase "filter" $ + rows (filter (\(spec,val) -> ("compiler", "gcc7") `elem` spec) mediumKVI) @?= + [ ([ "gcc7", "yes", "0"], "good" ) + , ([ "gcc7", "yes", "3"], "ugly" ) + , ([ "gcc7", "no", "0"], "bad" ) + , ([ "gcc7", "no", "1"], "good" ) + ] + + , testCaseSteps "zoo contents" $ \step -> do + step "LA Lions" + Just 4 @=? lookup [ ("Location", "LA"), ("Name", "Lion") + , ("Diet", "Carnivore"), ("Category", "Animal") + , ("Biome", "Savannah"), ("Subtype", "") + ] zooTable2 + step "No polar lions" + Nothing @=? lookup [ ("Location", "LA"), ("Name", "Lion") + , ("Diet", "Carnivore"), ("Category", "Animal") + , ("Biome", "Polar"), ("Subtype", "") + ] zooTable2 + + , testGroup "rendering" + [ + testAsciiRendering + , testHTMLRendering + ] + + ] diff --git a/test/TestQQDefs.hs b/test/TestQQDefs.hs new file mode 100644 --- /dev/null +++ b/test/TestQQDefs.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module TestQQDefs where + +import Data.String +import Language.Haskell.TH.Quote + + +sq :: QuasiQuoter +sq = qqExtractor 1 "\n****" + +sq_f = quoteFile sq +sq2_f = quoteFile $ qqExtractor 2 "\n****" +sq3_f = quoteFile $ qqExtractor 3 "\n****" + +uq :: QuasiQuoter +uq = qqExtractor 1 "\n____" + +uq_f = quoteFile uq +uq2_f = quoteFile $ qqExtractor 2 "\n____" +uq3_f = quoteFile $ qqExtractor 3 "\n____" + +qqExtractor idx sep = QuasiQuoter (extractor idx sep) + (error "no patterns supported") + (error "no types supported") + (error "no declarations supported") + +-- extractor :: String -> String -> QState +extractor idx sep s = + case inSeps idx sep $ filter (/= '\r') s of + Post a -> [|fromString a|] + Pre n _ -> error $ "No starting line found for block " <> show n + MatchLine n -> error $ "Only starting line found for block " <> show n + Pass n _ -> error $ "No ending line found for block " <> show n + +data QState = Pre Int String | MatchLine Int | Pass Int String | Post String + +inSeps :: Int -> String -> String -> QState +inSeps idx sep = + let sepl = length sep + nxtC :: QState -> Char -> QState + nxtC (Pre n p) c = let p' = c : p + l = length p' + in if reverse p' == take l sep + then if l == sepl then MatchLine n else Pre n p' + else Pre n $ take (sepl-1) p' + nxtC p@(MatchLine n) c = if '\n' == c then Pass n "" else p + nxtC (Pass n s) c = let s' = c : s + sl = reverse $ take sepl s' + in if sl == sep + then if n == 1 + then Post (reverse $ drop (sepl-1) s') + else Pre (n - 1) "" + else Pass n s' + nxtC (Post s) _ = Post s + in foldl nxtC (Pre idx "")