diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,14 @@ # Revision history for KVITable -## 1.0 3.0 -- 2024-02-22 +## 1.1.0.0 -- 2024-09-18 + +* The `RenderConfig.sortKeyVals` changed from a `Boolean` to a `Maybe fn`, where + the `fn` is a sorting function which is provided a `(rowKeyvals, colKeyvals)` + tuple and should return that tuple, sorted. The `sortNumericAlpha` function + can be used to obtain the old 'True' behavior. +* Support GHC 9.10. + +## 1.0.3.0 -- 2024-02-22 * Support GHC 9.8. * Internal updates to confirm safety and avoid partial functions. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -83,87 +83,87 @@ - - - - + + + + - - + + - - - - + + + + - - + + - + - + - - + + - + - + - - + + - + - + @@ -200,49 +200,49 @@
millionsthousands12
millions
thousands
1
2
  ←hundreds
22
2
2
  ←tens
0101
0
1
0
1
  ←ones
00
0
0
 even odd even odd
1
1
 even odd even odd
2
2
 even odd even odd
10
1
0
 even odd even odd
1
1
 even odd even odd
2
2
 even odd even odd
20
2
0
 even odd even odd
1
1
 even odd even odd
2
2
 even odd even
- - - - + + + + - - - - - - + + + + + + - - - - - - + + + + + + - - - - - - - - - - - - + + + + + + + + + + + + - + @@ -257,7 +257,7 @@ - + @@ -272,7 +272,7 @@ - + @@ -347,205 +347,205 @@
millions012
millions
0
1
2
  ←thousands
121212
1
2
1
2
1
2
  ←hundreds
222222
2
2
2
2
2
2
  ←tens
010101010101
0
1
0
1
0
1
0
1
0
1
0
1
  ←ones
0
0
 even odd evenodd
1
1
 even odd evenodd
2
2
 even odd even
- - - - - - + + + + + + - - - - - + + + + + - + - - - + + + - + - - - - + + + + - + - - - + + + - + - - - - + + + + - + - - - + + + - + - - - - - + + + + + - + - - - + + + - + - - - - + + + + - + - - - + + + - + - - - - + + + + - + - - - + + + - + - - - - - + + + + + - + - - - + + + - + - - - - + + + + - + - - - + + + - + - - - - + + + + - + - - - + + + - + diff --git a/examples/hundreds_all.md b/examples/hundreds_all.md --- a/examples/hundreds_all.md +++ b/examples/hundreds_all.md @@ -38,42 +38,42 @@
millionsthousandshundredstensonesValue
millions
thousands
hundreds
tens
ones
Value
00120
0
0
1
2
0
 even
1
1
 odd
220
2
2
0
 even
1
1
 odd
1120
1
1
2
0
 even
1
1
 odd
220
2
2
0
 even
1
1
 odd
2120
2
1
2
0
 even
1
1
 odd
220
2
2
0
 even
1
1
 odd
10120
1
0
1
2
0
 even
1
1
 odd
220
2
2
0
 even
1
1
 odd
1120
1
1
2
0
 even
1
1
 odd
220
2
2
0
 even
1
1
 odd
2120
2
1
2
0
 even
1
1
 odd
220
2
2
0
 even
1
1
 odd
20120
2
0
1
2
0
 even
1
1
 odd
220
2
2
0
 even
1
1
 odd
1120
1
1
2
0
 even
1
1
 odd
220
2
2
0
 even
1
1
 odd
2120
2
1
2
0
 even
1
1
 odd
220
2
2
0
 even
1
1
 odd
- - - - - + + + + + - - - - - - + + + + + + - - - - - - - - - - - - + + + + + + + + + + + + - - + + @@ -88,7 +88,7 @@ - + @@ -103,7 +103,7 @@ - + @@ -118,8 +118,8 @@ - - + + @@ -134,7 +134,7 @@ - + @@ -149,7 +149,7 @@ - + @@ -164,8 +164,8 @@ - - + + @@ -180,7 +180,7 @@ - + @@ -195,7 +195,7 @@ - + diff --git a/examples/zoo.md b/examples/zoo.md --- a/examples/zoo.md +++ b/examples/zoo.md @@ -64,122 +64,122 @@
millionsthousands012
millions
thousands
0
1
2
  ←hundreds
020202
0
2
0
2
0
2
  ←tens
010101010101
0
1
0
1
0
1
0
1
0
1
0
1
  ←ones
00
0
0
 odd
1
1
 odd
2
2
 odd
10
1
0
 odd
1
1
 odd
2
2
 odd
20
2
0
 odd
1
1
 odd
2
2
- - - - - - - + + + + + + + - - - - - - + + + + + + - - - - - + + + + + - - - + + + - - + + - - - - - - + + + + + + - - - - - + + + + + - - - + + + - - - - - - + + + + + + - - - - - - + + + + + + - - - - - + + + + + - + - - - - - + + + + + - - - - + + + + - + - - - - - + + + + + @@ -228,25 +228,25 @@
LocationBiomeCategoryDietNameSubtypeCount
Location
Biome
Category
Diet
Name
Subtype
Count
LAJungleAnimalHerbivoreHippo
LA
Jungle
Animal
Herbivore
Hippo
 1
SavannahAnimalCarnivoreLion
Savannah
Animal
Carnivore
Lion
 4
HerbivoreGiraffe
Herbivore
Giraffe
 2
Rhino
Rhino
 3
MiamiPolarBirdCarnivorePenguinGentoo
Miami
Polar
Bird
Carnivore
Penguin
Gentoo
 20
SavannahAnimalCarnivoreLion
Savannah
Animal
Carnivore
Lion
 2
HerbivoreGiraffeReticulated
Herbivore
Giraffe
Reticulated
 3
New YorkSavannahAnimalCarnivoreLion
New York
Savannah
Animal
Carnivore
Lion
 3
San DiegoJungleAnimalOmnivoreBearSun
San Diego
Jungle
Animal
Omnivore
Bear
Sun
 1
PlainsAnimalOmnivoreBearBlack
Plains
Animal
Omnivore
Bear
Black
 1
Brown
Brown
 1
PolarAnimalOmnivoreBearPolar
Polar
Animal
Omnivore
Bear
Polar
 1
BirdCarnivorePenguinEmperor
Bird
Carnivore
Penguin
Emperor
 8
Gentoo
Gentoo
 2
SavannahAnimalCarnivoreLion
Savannah
Animal
Carnivore
Lion
 9
- - - - - - - - - - + + + + + + + + + + - - - - + + + + - - - + + + - + @@ -289,10 +289,10 @@ - - - - + + + + - - - + + + - + @@ -336,10 +336,10 @@ - - - - + + + + - - - - + + + + @@ -370,9 +370,9 @@ - - - + + + @@ -386,9 +386,9 @@ - - - + + + @@ -402,8 +402,8 @@ - - + + - - - + + + diff --git a/kvitable.cabal b/kvitable.cabal --- a/kvitable.cabal +++ b/kvitable.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: kvitable -version: 1.0.3.0 +version: 1.1.0.0 synopsis: Key/Value Indexed Table container and formatting library description: . @@ -46,18 +46,23 @@ library hs-source-dirs: src default-language: Haskell2010 - GHC-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wpartial-fields -fhide-source-paths - -- other-extensions: + GHC-options: -Wall + -Wcompat + -Wincomplete-uni-patterns + -Wpartial-fields + -fhide-source-paths exposed-modules: Data.KVITable + , Data.KVITable.Internal.Helpers , Data.KVITable.Render , Data.KVITable.Render.ASCII , Data.KVITable.Render.HTML - -- other-modules: - build-depends: base >=4.12 && <4.20 + , Data.KVITable.Render.Internal + build-depends: base >=4.12 && <4.21 , containers , lucid >= 2.9 && < 2.12 , microlens >= 0.4 && < 0.5 - , prettyprinter >= 1.7 && < 1.8 + , named-text >= 1.2 && < 1.3 + , sayable >= 1.2.4.0 && < 1.3 , text test-suite test-kvitable @@ -74,7 +79,6 @@ , html-parse , kvitable , microlens - , pretty-show , tasty , tasty-hunit , template-haskell diff --git a/src/Data/KVITable.hs b/src/Data/KVITable.hs --- a/src/Data/KVITable.hs +++ b/src/Data/KVITable.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} @@ -17,11 +18,14 @@ , fromList , toList , Data.KVITable.lookup + , lookup' , keyVals , keyValGen , valueColName , insert + , insertWith , foldlInsert + , foldlInsertWith , Data.KVITable.filter , adjust , adjustWithKey @@ -35,11 +39,13 @@ import Data.Function ( on ) import qualified Data.List as L import qualified Data.Map as Map -import Data.Text ( Text ) +import Data.Name import qualified GHC.Exts import Lens.Micro ( Lens' ) +import Data.KVITable.Internal.Helpers + -- | 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. @@ -62,7 +68,7 @@ -- the defaultKeyVal for any keys not explicitly provided for that -- value. - , valuecolName :: Text -- ^ name of the value cells + , valuecolName :: Named HTMLStyle "column header" -- ^ name of the value cells } instance Eq v => Eq (KVITable v) where @@ -78,11 +84,11 @@ -- | 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 +type Key = Name "Key" -- | 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 +type KeyVal = Name "KeyVal" -- | The 'KeySpec' is the list of tuples and defines the unique key -- for a value in the 'KVITable'. @@ -150,19 +156,19 @@ 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. +-- | 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; existing entries in the table under the old keys are NOT +-- migrated to the new table entries. 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 + let inKVS spec _val = + length kvs == length spec + && and (keymatch <$> zip spec kvs) + keymatch ((sk,sv), (k,vs)) = sk == k && sv `elem` vs in Map.filterWithKey inKVS (contents t) } ) <$> f (keyvals t) @@ -176,7 +182,7 @@ -- | Fetch or set the column name for the actual value cell in the -- 'KVITable'. -valueColName :: Lens' (KVITable v) Text +valueColName :: Lens' (KVITable v) (Named HTMLStyle "column header") valueColName f t = (\n -> t { valuecolName = n } ) <$> f (valuecolName t) @@ -186,6 +192,13 @@ -- 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. +-- +-- The performance of lookup degrades exponentially on a sparse KVITable: an +-- unset KVITable entry is indistinguishable from a non-normalized keyspec, so if +-- the initial query fails, the keyspec is normalized and then the lookup is +-- re-attempted. This may be fine for an individual query, but for large numbers +-- of queries this is excessively slow. To mitigate this, the lookup' can be +-- used, which assumes the use of a normalized key. lookup :: KeySpec -> KVITable v -> Maybe v lookup keyspec t = case Map.lookup keyspec $ contents t of @@ -198,11 +211,20 @@ 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) + Just v -> + if v `elem` vs then snoc s (k,v) + else s -- no level added, so this should never match in the Map + Nothing -> snoc s (k, keyvalGen t k) + in foldl keyandval mempty (keyvals t) + +-- | Like 'lookup', but assumes a normalized key (all key elements specified, and +-- in the proper order). Faster than 'lookup', but will return false negatives +-- if not used with a normalized key. + +lookup' :: KeySpec -> KVITable v -> Maybe v +lookup' keyspec = Map.lookup keyspec . contents + -- | Inserts a new cell value into the table at the specified keyspec -- location. The keyspec may be minimally specified and out-of-order. -- @@ -210,10 +232,25 @@ -- for the table. In general, insertion is expected to be less -- frequent than lookups so computation costs are biased towards the -- insertion operation. +-- +-- This is equivalent to @insertWith const@. insert :: KeySpec -> v -> KVITable v -> KVITable v -insert keyspec val t = endset t val (keyvals t) keyspec [] [] +insert = insertWith const +-- | Inserts a new cell value into the table at the specified keyspec +-- location, if no value exists at that location. Otherwise, the old and +-- new value are combined via @f new old@. 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. + +insertWith :: (v -> v -> v) -> KeySpec -> v -> KVITable v -> KVITable v +insertWith f keyspec val t = endsetWith f t val (keyvals t) keyspec mempty mempty + remainingKeyValDefaults :: KVITable v -> [(Key,a)] -> KeySpec remainingKeyValDefaults t = fmap (\(k,_) -> (k, keyvalGen t k)) @@ -222,18 +259,18 @@ then e else (k, keyvalGen t k : vs) -endset :: KVITable v -> v -> KeyVals -> KeySpec -> KeySpec -> KeyVals -> KVITable v -endset t val rkv [] tspec kvbld = +endsetWith :: (v -> v -> v) -> KVITable v -> v -> KeyVals -> KeySpec -> KeySpec -> KeyVals -> KVITable v +endsetWith f 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) + in t { contents = Map.insertWith f spec val (contents t) , keyvals = kvbld <> (addDefVal t <$> rkv) } -endset t val [] spec tspec kvbld = +endsetWith f 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 @@ -241,46 +278,56 @@ -- default values for the new keys in their keyspec. let spec' = tspec <> spec keySpecElemToKeyVals (k,v) = (k, if null curTblList - then [v] + then single 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 + in t { contents = Map.insertWith f spec' val $ Map.fromList updTblList , keyvals = keyvals' } -endset t val kvs@((k,vs):rkvs) ((sk,sv):srs) tspec kvbld = +endsetWith f 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' + then snoc kvbld (k, vs) + else snoc kvbld (k, sv : vs) + in endsetWith f t val rkvs srs (snoc 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 + then endsetWith f t val kvs (snoc srs (sk,sv)) tspec kvbld else if any (`elem` (fst <$> kvs)) (fst <$> srs) - then endset t val kvs (srs <> [(sk,sv)]) tspec kvbld + then endsetWith f t val kvs (snoc 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')]) + in endsetWith f t val rkvs ((sk,sv):srs) (snoc tspec (k,defVal)) (snoc kvbld (k,vs')) --- | The foldlInsert is a convenience function that can be specified +-- | 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. +-- +-- This is equivalent to @foldlInsertWith const@. foldlInsert :: KVITable v -> (KeySpec, v) -> KVITable v -foldlInsert t (k,v) = insert k v t +foldlInsert = foldlInsertWith const +-- | foldlInsertWith is a convenience function that, when curried with a +-- "combining" function, can be specified as the function argument of a foldl +-- operation over the list form of a KVITable to generate the associated +-- KVITable. +foldlInsertWith :: (v -> v -> v) -> KVITable v -> (KeySpec, v) -> KVITable v +foldlInsertWith f t (k,v) = insertWith f k v t + + -- | Filter 'KVITable' to retain only the elements that satisfy some predicate. filter :: ((KeySpec, v) -> Bool) -> KVITable v -> KVITable v @@ -328,16 +375,16 @@ 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 +-- list structure, where each returned 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) [] +rows t = go (keyvals t) mempty where go [] spec = let spec' = reverse spec in case Map.lookup spec' (contents t) of - Nothing -> [] - Just v -> [ (snd <$> spec', v) ] + Nothing -> mempty + Just v -> single (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/Internal/Helpers.hs b/src/Data/KVITable/Internal/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Data/KVITable/Internal/Helpers.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE DataKinds #-} + +module Data.KVITable.Internal.Helpers where + +import Data.Name ( Name ) + + +type Keys = [Name "Key"] + + +single :: e -> [e] +single = (:[]) + +snoc :: [a] -> a -> [a] +snoc l e = l <> [e] + +maxOf :: (Foldable t, Ord e) => e -> t e -> e +maxOf v l = if null l then v else max v $ maximum l diff --git a/src/Data/KVITable/Render.hs b/src/Data/KVITable/Render.hs --- a/src/Data/KVITable/Render.hs +++ b/src/Data/KVITable/Render.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DataKinds #-} + -- | Common definitions (and support functions) for rendering a -- 'KVITable'. @@ -5,15 +7,18 @@ ( RenderConfig(..) , defaultRenderConfig - , sortWithNums + , sortNumericAlpha ) where -import Data.KVITable import qualified Data.List as L -import Data.Text ( Text ) +import Data.Name ( Name, nameText, nameLength, nullName ) import qualified Data.Text as T +import Numeric.Natural +import Data.KVITable + + -- | Returns the default rendering configuration, to be used with a -- format-specific @render@ call. @@ -22,16 +27,18 @@ { hideBlankRows = True , hideBlankCols = True , equisizedCols = True - , sortKeyVals = False + , sortKeyVals = Nothing , colStackAt = Nothing , rowRepeat = True , rowGroup = [] , caption = Nothing + , maxCells = 40000 -- even this is probably too big + , maxCols = 40000 -- by default, this should be >= maxCells } -- | 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 +-- The 'RenderConfig' is global to all formats, although some of the -- fields in the 'RenderConfig' will be ignored as not-applicable by -- some formats. @@ -50,13 +57,31 @@ -- (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. + , sortKeyVals :: Maybe ((KeyVals, KeyVals) -> (KeyVals, KeyVals)) + -- ^ Specifies a function to sort the KeyVals (rows and columns, + -- respectively) for the output. If no function provided, no sorting is + -- performed. The provided KeyVals are in the order in which the Keys are + -- declared to the KVITable; the values for each key may be in an arbitrary + -- order. The usual expectation is that this will only sort the values for + -- each Key, but it is allowed to re-order the Keys as well. + -- + -- Sorting is done *prior* to applying maxCells and maxCols limitations; this + -- provides the unsurprising results for the user but means that this + -- function may perform extra work to sort rows and columns that will not be + -- shown. + -- + -- It is permissible to move entries from the rows to the columns and + -- vice-versa; this function has control over the shape of the resulting + -- table, which includes redistributing the rows and columns such that the + -- result will violate maxCols (but not maxCells). + -- + -- The columns keyvals will be empty if colStackAt is Nothing. , colStackAt :: Maybe Key - -- ^ Column key to begin stacking keys in columns and sub-columns - -- rather than creating additional sub-rows. + -- ^ Column key to begin stacking keys in columns and sub-columns rather than + -- creating additional sub-rows. This is performed on the + -- originally-specified key order, prior to calling any provided + -- 'sortKeyVals' function. , rowRepeat :: Bool -- ^ 'True' (default) if an identical 'KeyVal' is to be repeated @@ -66,13 +91,56 @@ -- ^ List of Key names that should by grouped by inserting -- horizontal row lines between KeyVals - , caption :: Maybe Text + , caption :: Maybe (Name "caption") -- ^ Caption to render for table for backends which support -- captions; otherwise ignored. + + , maxCells :: Natural + -- ^ The maximum number of cells that will be rendered. The size of the + -- table is #rows times #cols, so a 100x100 table is 10000 entries. This + -- value is used to limit the size of the rendered table to provide a + -- reasonable output in a reasonable amount of time and memory; tables larger + -- than this limit will return a "table too big" message when rendered. + -- + -- ASCII: At least 1 character for the cell, plus 3.5 characters for + -- boundaries means that even on an ultra-wide monitor with a very small + -- font, the table isn't very readable beyond 30-40 columns. In addition, + -- the algorithm needs to continually adjust table column widths to + -- accomodate new values, so there is a great deal of backtracking involved + -- and the time taken to render grows quite quickly. + -- + -- HTML: A browser has reasonable constraints on displaying a table: 10000 + -- entries is difficult for the user to comprehend, but the browser is + -- probably reasonably performant. At 500x500, the browser is likely to be + -- very sluggish, with visible delays in rendering visible regions during + -- scrolling. + + , maxCols :: Natural + -- ^ The maximum number of columns to render. This limit is only useful if + -- it is set to less than the 'maxCells' value, and it is useful in that case + -- to ensure that more than one (partial) row is displayed. The 'maxCells' + -- value takes priority over this value. See the 'maxCells' for more + -- information. } +-- | Table KeyVals sorting function; alphanumeric with numeric preference. This +-- can be used as the sortKeyVals function for the table. +-- +-- 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. + +sortNumericAlpha :: (KeyVals, KeyVals) -> (KeyVals, KeyVals) +sortNumericAlpha (rowkeys, colkeys) = ( fmap sortWithNums <$> rowkeys + , fmap sortWithNums <$> colkeys + ) + + -- | 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 @@ -87,10 +155,10 @@ 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'] + rank e = if (not $ nullName e) && + or [ T.head (nameText e) `elem` ['0'..'9'] + , T.last (nameText e) `elem` ['0'..'9'] ] - then T.length e + then nameLength e else 0 in snd <$> L.sort skvs diff --git a/src/Data/KVITable/Render/ASCII.hs b/src/Data/KVITable/Render/ASCII.hs --- a/src/Data/KVITable/Render/ASCII.hs +++ b/src/Data/KVITable/Render/ASCII.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -17,14 +19,20 @@ where import qualified Data.List as L -import Data.Maybe ( fromMaybe, isNothing ) +import Data.Maybe ( isNothing ) +import Data.Name +import Data.String ( fromString ) import Data.Text ( Text ) import qualified Data.Text as T import Lens.Micro ( (^.) ) -import qualified Prettyprinter as PP +import Numeric.Natural +import Text.Sayable -import Data.KVITable +import Data.KVITable ( KVITable, KeySpec, keyVals ) +import qualified Data.KVITable as KVIT +import Data.KVITable.Internal.Helpers import Data.KVITable.Render +import Data.KVITable.Render.Internal import Prelude hiding ( lookup ) @@ -32,27 +40,27 @@ -- | Renders the specified table in ASCII format, using the specified -- 'RenderConfig' controls. -render :: PP.Pretty v => RenderConfig -> KVITable v -> Text +render :: Sayable "normal" 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 + let kmap = renderingKeyVals cfg $ t ^. keyVals + (fmt, hdr) = renderHdrs cfg t kmap + bdy = renderSeq cfg fmt kmap t in T.unlines $ hdr <> bdy ---------------------------------------------------------------------- -data FmtLine = FmtLine [Int] Sigils Sigils -- last is for sepline +data FmtLine = FmtLine [Natural] Sigils Sigils -- last is for sepline data Sigils = Sigils { sep :: Text, pad :: Text, cap :: Text } -fmtLine :: [Int] -> FmtLine +fmtLine :: [Natural] -> FmtLine fmtLine cols = FmtLine cols Sigils { sep = "|", pad = " ", cap = "_" } Sigils { sep = "+", pad = "-", cap = "_" } -fmtColCnt :: FmtLine -> Int -fmtColCnt (FmtLine cols _ _) = length cols +fmtColCnt :: FmtLine -> Natural +fmtColCnt (FmtLine cols _ _) = nLength cols -perColOvhd :: Int +perColOvhd :: Natural perColOvhd = 2 -- pad chars on either side of each column's entry -- | Formatted width of output, including pad on either side of each @@ -61,18 +69,19 @@ -- 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 -> Natural fmtWidth (FmtLine cols _ _) = let cols' = L.filter (/= 0) cols - in sum cols' + ((perColOvhd + 1) * (length cols' - 1)) + in sum cols' + ((perColOvhd + 1) * (nLength cols' - 1)) fmtEmptyCols :: FmtLine -> Bool fmtEmptyCols (FmtLine cols _ _) = sum cols == 0 -fmtAddColLeft :: Int -> FmtLine -> FmtLine +fmtAddColLeft :: Natural -> FmtLine -> FmtLine fmtAddColLeft leftCol (FmtLine cols s s') = FmtLine (leftCol : cols) s s' data FmtVal = Separator | TxtVal Text | CenterVal Text + | Overage -- cells for the overflow row/column fmtRender :: FmtLine -> [FmtVal] -> Text fmtRender (FmtLine _cols _sigils _sepsigils) [] = "" @@ -82,20 +91,28 @@ Separator -> f sepsigils TxtVal _ -> f sigils CenterVal _ -> f sigils + Overage -> f sigils l = sig sep val + charRepeat n c = T.pack (replicate (fromEnum n) c) + rightAlign n t = let tl = toEnum $ T.length t + rt = charRepeat (n - tl) ' ' <> t + in if tl >= n then t else rt + centerIn n t = let tl = toEnum $ T.length t + (w,e) = (n - tl - 2) `divMod` 2 + m = cap sigils + ls = T.replicate (fromEnum $ w + 0) m + rs = T.replicate (fromEnum $ w + e) m + in if tl + 2 >= n + then rightAlign n t + else ls <> " " <> t <> " " <> rs 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 + Separator -> charRepeat sz '-' + TxtVal v -> rightAlign sz v + CenterVal t -> centerIn sz t + Overage -> centerIn sz "+" ) <> sig pad fld <> sig sep fld -- KWQ or if next fld is Nothing @@ -109,75 +126,83 @@ data HeaderLine = HdrLine FmtLine HdrVals Trailer type HdrVals = [FmtVal] -type Trailer = Text +type Trailer = Name "column header" hdrFmt :: HeaderLine -> FmtLine hdrFmt (HdrLine fmt _ _) = fmt -renderHdrs :: PP.Pretty v => RenderConfig -> KVITable v -> [Key] -> (FmtLine, [Text]) -renderHdrs cfg t keys = +renderHdrs :: Sayable "normal" v + => RenderConfig -> KVITable v -> (TblHdrs, TblHdrs) + -> (FmtLine, [Text]) +renderHdrs cfg t kmap = ( lastFmt , [ fmtRender fmt hdrvals - <> (if T.null trailer then "" else (" <- " <> trailer)) + <> (if nullName trailer then "" else (" <- " <> nameText trailer)) | (HdrLine fmt hdrvals trailer) <- hrows ] <> - [ fmtRender lastFmt (replicate (fmtColCnt lastFmt) Separator) ]) + (single $ let sz = fromEnum $ fmtColCnt lastFmt + in fmtRender lastFmt (replicate sz Separator)) ) where - hrows = hdrstep cfg t keys + hrows = hdrstep cfg t kmap lastFmt = case reverse hrows of - [] -> fmtLine [] + [] -> fmtLine mempty (hrow:_) -> hdrFmt hrow -hdrstep :: PP.Pretty v => RenderConfig -> KVITable v -> [Key] -> [HeaderLine] -hdrstep _cfg t [] = +hdrstep :: Sayable "normal" v + => RenderConfig + -> KVITable v + -> (TblHdrs, TblHdrs) + -> [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 + let valcoltxt = t ^. KVIT.valueColName + valcoltsz = nameLength valcoltxt + valsizes = nLength . sez @"normal" . snd <$> KVIT.toList t + valwidth = maxOf 0 $ valcoltsz : valsizes + hdrVal = TxtVal $ nameText valcoltxt + in single $ HdrLine (fmtLine $ single valwidth) (single hdrVal) "" +hdrstep cfg t ([], colKeyMap) = + hdrvalstep cfg t colKeyMap mempty -- switch to column-stacking mode +hdrstep cfg t ((key,keyvals) : keys, colKeyMap) = + let keyw = max (nameLength key) + $ (maxOf 0 . fmap (nameLength . toHdrText)) keyvals + mkhdr (hs, v) (HdrLine fmt hdrvals trailer) = + ( HdrLine (fmtAddColLeft keyw fmt) (TxtVal (nameText v) : hdrvals) trailer : hs , "") + in reverse $ fst $ foldl mkhdr (mempty, key) $ hdrstep cfg t (keys, colKeyMap) + -- 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 +hdrvalstep :: Sayable "normal" v + => RenderConfig -> KVITable v -> TblHdrs -> KeySpec + -> [HeaderLine] +hdrvalstep cfg t ((key,titles) : []) steppath = + let cvalWidths = \case + V kv -> fmap (nLength . sez @"normal" . snd) + $ filter ((L.isSuffixOf (snoc steppath (key, kv))) . fst) + $ KVIT.toList t + AndMore _ -> [1] -- always show this column, although it has no contents colWidth kv = let cvw = cvalWidths kv - in if and [ hideBlankCols cfg, sum cvw == 0 ] - then 0 - else maximum $ T.length kv : cvw + in if hideBlankCols cfg && sum cvw == 0 + then 0 + else maxOf (nameLength $ toHdrText kv) cvw cwidths = fmap colWidth titles fmtcols = if equisizedCols cfg - then (replicate (length cwidths) (maximum cwidths)) + then (replicate (length cwidths) (maxOf 0 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) + tr = convertName key + hdrTxt = nameText . toHdrText + in single $ HdrLine (fmtLine $ fmtcols) (TxtVal . hdrTxt <$> titles) tr +hdrvalstep cfg t ((key,vals) : keys) steppath = + let subhdrsV = \case + V v -> hdrvalstep cfg t keys (snoc steppath (key,v)) + _ -> mempty + subTtlHdrs = let subAtVal v = (nameLength $ toHdrText v, subhdrsV v) in fmap subAtVal vals szexts = let subW (hl,sh) = case sh of [] -> (0, 0) -- should never be the case (sh0:_) -> let sv = fmtWidth $ hdrFmt sh0 - in if and [ hideBlankCols cfg, - fmtEmptyCols $ hdrFmt sh0 - ] + in if hideBlankCols cfg && (fmtEmptyCols $ hdrFmt sh0) then (0, 0) else (hl, sv) in fmap (uncurry max . subW) subTtlHdrs @@ -185,68 +210,88 @@ L.transpose $ fmap (uncurry rsz_hdrstack) $ zip szhdrs $ fmap snd subTtlHdrs - largest = maximum szexts + largest = maxOf 0 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)) + numNZCols = nLength nzCols + pcw = sum nzCols + ((perColOvhd + 1) * (numNZCols - 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 + else max 0 (hw - pcw) `divMod` numNZCols + c' = fst $ foldl (\(c'',n) w -> (snoc c'' $ n+w, ew)) (mempty,ew+w0) c in HdrLine (FmtLine c' s j) v r - hdrJoin hl = foldl hlJoin (HdrLine (fmtLine []) [] "") hl + hdrJoin hl = foldl hlJoin (HdrLine (fmtLine mempty) mempty "") 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 + tvals = CenterVal . nameText . toHdrText <$> vals + in HdrLine (fmtLine szhdrs) tvals (convertName key) : rsz_extsubhdrs +hdrvalstep _ _ [] _ = error "ASCII hdrvalstep with empty keys after matching colStackAt -- impossible" -renderSeq :: PP.Pretty v => RenderConfig -> FmtLine -> [Key] -> KVITable v -> [Text] -renderSeq cfg fmt keys kvitbl = fmtRender fmt . snd <$> asciiRows keys [] +toHdrText :: TblHdr -> Name "column header" +toHdrText = \case + V kv -> convertName kv + AndMore n -> fromString $ sez @"normal" $ t'"{+" &+ n &+ '}' + +---------------------------------------------------------------------- + +renderSeq :: Sayable "normal" v + => RenderConfig + -> FmtLine + -> (TblHdrs, TblHdrs) + -> KVITable v + -> [Text] +renderSeq cfg fmt kmap kvitbl = fmtRender fmt . snd <$> asciiRows kmap mempty where - asciiRows :: [Key] -> KeySpec -> [ (Bool, [FmtVal]) ] - asciiRows [] path = - let v = lookup path kvitbl + filterBlank = if hideBlankRows cfg + then L.filter (not . all isNothing . snd) + else id + asciiRows :: (TblHdrs, TblHdrs) + -> KeySpec + -> [ (Bool, [FmtVal]) ] + asciiRows ([], []) path = + let v = KVIT.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 = \case - subs@(sub0:_) | key `elem` rowGroup cfg -> - let subl = [ (True, replicate (length $ snd sub0) Separator) ] - in if fst (last subs) - then init subs <> subl - else subs <> subl - subs -> 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 + in if skip then mempty + else single $ (False, single $ maybe (TxtVal "") TxtVal (T.pack . sez @"normal" <$> v) ) + asciiRows ([], colKeyMap) path = + let filterOrDefaultBlankRows = fmap (fmap defaultBlanks) . filterBlank + defaultBlanks = fmap (\v -> maybe (TxtVal "") TxtVal v) + in filterOrDefaultBlankRows $ single $ (False, multivalRows colKeyMap path) + asciiRows ((key, keyvals) : kseq, colKeyMap) path = + let subrows = \case + V keyval -> asciiRows (kseq, colKeyMap) $ snoc path (key, keyval) + _ -> + let ttlcols = product ( length . snd <$> colKeyMap) + in [ (False , replicate (ttlcols + length kseq) $ Overage) ] + grprow = \case + subs@(sub0:_) | key `elem` rowGroup cfg -> + let subl = single (True, replicate (length $ snd sub0) Separator) + in if fst (last subs) then init subs <> subl else subs <> subl + subs -> subs + genSubRow keyval = grprow $ fst + $ foldl leftAdd (mempty, toHdrText keyval) $ subrows keyval + leftAdd (acc,kv) (b,subrow) = + (snoc acc (b, TxtVal (nameText kv) : subrow) + , if rowRepeat cfg then kv else "" + ) + in concat (genSubRow <$> keyvals) + + multivalRows :: TblHdrs -> KeySpec -> [ Maybe Text ] + multivalRows ((key, keyvals) : []) path = + let showEnt = T.pack . sez @"normal" + in (\case + V v -> (showEnt <$> (KVIT.lookup' (snoc path (key,v)) kvitbl)) + _ -> Nothing + ) <$> keyvals + multivalRows ((key, keyvals) : kseq) path = + concatMap (\case + V v -> multivalRows kseq (snoc path (key,v)) + _ -> mempty + ) 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 --- a/src/Data/KVITable/Render/HTML.hs +++ b/src/Data/KVITable/Render/HTML.hs @@ -1,6 +1,11 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | This module provides the 'KVITable' 'render' function for -- rendering the table in a HTML table format. The various HTML table @@ -20,16 +25,22 @@ import qualified Data.List as L import Data.List.NonEmpty ( NonEmpty( (:|) ) ) import qualified Data.List.NonEmpty as NEL -import Data.Maybe ( fromMaybe, isNothing ) +import Data.Maybe ( isNothing ) +import Data.Name ( Named, HTMLStyle, UTF8, convertName + , convertStyle, nameText ) +import Data.String ( fromString ) 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 Numeric.Natural +import Text.Sayable -import Data.KVITable +import Data.KVITable as KVIT +import Data.KVITable.Internal.Helpers import Data.KVITable.Render +import Data.KVITable.Render.Internal import Prelude hiding ( lookup ) @@ -39,20 +50,27 @@ -- definition; it is intended to be embedded in a larger HTML -- document. -render :: PP.Pretty v => RenderConfig -> KVITable v -> Text +render :: Sayable "html" 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 + let kmap = renderingKeyVals cfg $ t ^. keyVals + (fmt, hdr) = renderHdrs cfg kmap t + bdy = renderSeq cfg fmt kmap t in TL.toStrict $ renderText $ table_ [ class_ "kvitable" ] $ - do maybe mempty (caption_ . toHtml) $ Data.KVITable.Render.caption cfg + do maybe mempty (caption_ . toHtml . convertStyle @UTF8 @HTMLStyle) + $ Data.KVITable.Render.caption cfg thead_ [ class_ "kvitable_head" ] hdr tbody_ [ class_ "kvitable_body" ] bdy + +instance ToHtml (Named HTMLStyle nameOf) where + toHtml = toHtmlRaw . nameText + -- Note: toHtml uses toHtmlRaw because Named HTMLStyle is already escaped + toHtmlRaw = toHtmlRaw . nameText + ---------------------------------------------------------------------- -data FmtLine = FmtLine [Int] -- colspans, length is # columns +data FmtLine = FmtLine [Natural] -- colspans, length is # columns instance Semigroup FmtLine where (FmtLine c1) <> (FmtLine c2) = FmtLine $ c1 <> c2 @@ -60,40 +78,56 @@ instance Monoid FmtLine where mempty = FmtLine mempty -fmtAddColLeft :: Int -> FmtLine -> FmtLine +fmtAddColLeft :: Natural -> FmtLine -> FmtLine fmtAddColLeft lspan (FmtLine col) = FmtLine $ lspan : col -data FmtVal = Val Height LastInGroup Text - | Hdr Height LastInGroup Text - deriving Show -type Height = Int +data FmtVal = Val Span LastInGroup Bool Text + | Hdr Span LastInGroup (Named HTMLStyle "column header") +data Span = Singular | Cols Width | Rows Height +type Height = Natural +type Width = Natural type LastInGroup = Bool -type RightLabel = Text +type RightLabel = Named HTMLStyle "column header" -fmtRender :: FmtLine -> [FmtVal] -> Maybe RightLabel -> Html () -fmtRender (FmtLine cols) vals mbRLabel = do +fmtRender :: FmtLine -> Maybe RightLabel -> [FmtVal] -> Html () +fmtRender (FmtLine cols) mbRLabel vals = 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 [] + , case h of + Singular -> mempty + Cols n -> if w == 1 && n == 1 + then mempty + else [ colspan_ $ T.pack $ show (n*w) + , class_ " multicol" + ] + Rows 1 -> mempty + Rows n -> [ rowspan_ $ T.pack $ show n ] + , if w == 1 + || case h of + Cols n | n > 1 -> True + _ -> False + then mempty else [ colspan_ $ T.pack $ show w , class_ " multicol" ] - , if l then [ class_ " last_in_group" ] else [] + , if l then [ class_ " last_in_group" ] else mempty ] - in th_ (concat $ reverse a) (toHtml v) - cell (w,Val h l v) = + in th_ (concat $ reverse a) (div_ $ span_ $ toHtml v) + cell (w,Val h l i v) = let a = [ [ class_ "kvitable_td" ] - , if h == 1 then [] - else [ rowspan_ $ T.pack $ show h ] - , if w == 1 then [] + , case h of + Singular -> mempty + Cols 1 -> mempty + Cols n -> [ colspan_ $ T.pack $ show n ] + Rows 1 -> mempty + Rows n -> [ rowspan_ $ T.pack $ show n ] + , if w == 1 then mempty else [ colspan_ $ T.pack $ show w , class_ " multicol" ] - , if l then [ class_ " last_in_group" ] else [] + , if l then [ class_ " last_in_group" ] else mempty ] - in td_ (concat $ reverse a) (toHtml v) + in td_ (concat $ reverse a) $ if i then i_ (toHtml v) else toHtml v labelMark = toHtmlRaw (" ←" :: Text) labelHtml = th_ [ class_ "rightlabel kvitable_th" ] . (labelMark <>) . @@ -107,7 +141,7 @@ data HeaderLine = HdrLine FmtLine HdrVals Trailer type HdrVals = [FmtVal] -type Trailer = Maybe Text +type Trailer = Maybe RightLabel instance Semigroup HeaderLine where (HdrLine fmt1 hv1 t1) <> (HdrLine fmt2 hv2 _) = @@ -116,140 +150,177 @@ hdrFmt :: HeaderLine -> FmtLine hdrFmt (HdrLine fmt _ _) = fmt -renderHdrs :: PP.Pretty v - => RenderConfig -> KVITable v -> [Key] +renderHdrs :: Sayable "html" v + => RenderConfig + -> (TblHdrs, TblHdrs) + -> KVITable v -> ( FmtLine, Html () ) -renderHdrs cfg t keys = ( rowfmt, sequence_ hdrs ) +renderHdrs cfg kmap t = ( rowfmt, sequence_ hdrs ) where hdrs = fmap renderHdr hrows - (hrows, rowfmt) = hdrstep cfg t keys - renderHdr (HdrLine fmt hdrvals trailer) = fmtRender fmt hdrvals trailer + (hrows, rowfmt) = hdrstep cfg t kmap + renderHdr (HdrLine fmt hdrvals trailer) = fmtRender fmt trailer hdrvals -hdrstep :: PP.Pretty v - => RenderConfig -> KVITable v -> [Key] +hdrstep :: Sayable "html" v + => RenderConfig + -> KVITable v + -> (TblHdrs, TblHdrs) -> (NEL.NonEmpty 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 (nexthdr0 :| nexthdrs, lowestfmt) = hdrstep cfg t keys - (HdrLine fmt vals tr) = nexthdr0 - fmt' = fmtAddColLeft 1 fmt - val = Hdr (length nexthdrs + 1) False key - in ( (HdrLine fmt' (val : vals) tr) :| nexthdrs - , fmtAddColLeft 1 lowestfmt - ) +hdrstep _cfg t ([], []) = + let hdr = Hdr Singular False $ t ^. valueColName + one = single 1 + in ( HdrLine (FmtLine one) (single hdr) Nothing :| mempty + , FmtLine one + ) +hdrstep cfg t ([], colKeys) = + hdrvalstep cfg t colKeys mempty -- switch to column stacking mode +hdrstep cfg t ((key,_) : keys, colKeys) = + let (nexthdr0 :| nexthdrs, lowestfmt) = hdrstep cfg t (keys, colKeys) + (HdrLine fmt vals tr) = nexthdr0 + fmt' = fmtAddColLeft 1 fmt + val = Hdr (Rows $ nLength nexthdrs + 1) False + $ convertStyle $ convertName key + in ( (HdrLine fmt' (val : vals) tr) :| nexthdrs + , fmtAddColLeft 1 lowestfmt + ) -hdrvalstep :: PP.Pretty v - => RenderConfig -> KVITable v -> KeySpec -> [Key] +hdrvalstep :: Sayable "html" v + => RenderConfig + -> KVITable v + -> TblHdrs + -> KeySpec -> (NEL.NonEmpty 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 ordering = if sortKeyVals cfg then sortWithNums else id - in case ordering $ fromMaybe [] $ L.lookup key $ t ^. keyVals of - [] -> error "cannot happen" - (ttl:ttls) -> - let - titles = ttl :| ttls - subhdrsV v = hdrvalstep cfg t (steppath <> [(key,v)]) keys - subTtlHdrs :: NEL.NonEmpty (NEL.NonEmpty HeaderLine, FmtLine) - subTtlHdrs = subhdrsV <$> titles - subhdrs :: NEL.NonEmpty (NEL.NonEmpty HeaderLine, FmtLine) - subhdrs = if hideBlankCols cfg - then subTtlHdrs - else - -- Want to repeat the first element of subTtlHdrs to get a - -- NonEmpty the same length as titles. Both titles and - -- subTtlHdrs are NonEmpty, but NonEmpty has no replicate - -- function. - let n = length titles -- >= 1 because titles is NonEmpty - e = NEL.head subTtlHdrs - tail' = NEL.take (n-1) $ NEL.repeat e - in e :| tail' - subhdr_rollup = joinHdrs <$> NEL.transpose (fst <$> subhdrs) - joinHdrs :: NEL.NonEmpty HeaderLine -> HeaderLine - joinHdrs (hl0 :| hls) = foldl (<>) hl0 hls - superFmt :: (NEL.NonEmpty HeaderLine, FmtLine) -> Int - superFmt sub = let FmtLine subcols = hdrFmt $ NEL.last $ fst sub - in if sum subcols == 0 - then 0 - else length $ L.filter (/= 0) subcols - topfmt = FmtLine $ NEL.toList (superFmt <$> subhdrs) - tophdr = HdrLine topfmt (NEL.toList (Hdr 1 False <$> titles)) $ Just key - in ( NEL.cons tophdr subhdr_rollup, F.fold (snd <$> subTtlHdrs)) +hdrvalstep _ _ [] _ = error "HTML hdrvalstep with empty keys after matching colStackAt -- impossible" +hdrvalstep cfg t ((key, titles) : []) steppath = + let cvalWidths kv = fmap (length . sez @"html" . snd) $ + L.filter ((L.isSuffixOf (snoc steppath (key, kv))) . fst) + $ KVIT.toList t + cwidth = \case + V c -> if hideBlankCols cfg && 0 == (sum $ cvalWidths c) then 0 else 1 + AndMore _ -> 1 + fmt = FmtLine (cwidth <$> titles) + hdr = Hdr Singular False . toHdrText <$> titles + k = convertStyle @UTF8 @HTMLStyle $ convertName key + in ( HdrLine fmt hdr (Just k) :| mempty, fmt) +hdrvalstep _cfg _t ((_key, []) : _keys) _steppath = error "cannot happen" +hdrvalstep cfg t ((key, ttl:ttls) : keys) steppath = + let + titles = ttl :| ttls + subhdrsV v = hdrvalstep cfg t keys (case v of + V kv -> snoc steppath (key,kv) + _ -> steppath + ) + subTtlHdrs :: NEL.NonEmpty (NEL.NonEmpty HeaderLine, FmtLine) + subTtlHdrs = subhdrsV <$> titles + subhdrs :: NEL.NonEmpty (NEL.NonEmpty HeaderLine, FmtLine) + subhdrs = if hideBlankCols cfg + then subTtlHdrs + else + -- Want to repeat the first element of subTtlHdrs to get a + -- NonEmpty the same length as titles. Both titles and + -- subTtlHdrs are NonEmpty, but NonEmpty has no replicate + -- function. + let n = length titles -- >= 1 because titles is NonEmpty + e = NEL.head subTtlHdrs + tail' = NEL.take (n-1) $ NEL.repeat e + in e :| tail' + subhdr_rollup = joinHdrs <$> NEL.transpose (fst <$> subhdrs) + joinHdrs :: NEL.NonEmpty HeaderLine -> HeaderLine + joinHdrs (hl0 :| hls) = foldl (<>) hl0 hls + superFmt :: (NEL.NonEmpty HeaderLine, FmtLine) -> Natural + superFmt sub = let FmtLine subcols = hdrFmt $ NEL.last $ fst sub + in if sum subcols == 0 + then 0 + else nLength $ L.filter (/= 0) subcols + topfmt = FmtLine $ NEL.toList (superFmt <$> subhdrs) + tophdr = let h = Hdr Singular False . toHdrText <$> titles + tr = convertStyle @UTF8 @HTMLStyle $ convertName key + in HdrLine topfmt (NEL.toList h) $ Just tr + in ( NEL.cons tophdr subhdr_rollup, F.fold (snd <$> subTtlHdrs)) + +toHdrText :: TblHdr -> Named HTMLStyle "column header" +toHdrText th = case toHdrText' th of + Right t -> t + Left n -> fromString $ sez @"html" $ t'"{+" &+ n &+ '}' + +toHdrText' :: TblHdr -> Either Natural (Named HTMLStyle "column header") +toHdrText' = \case + V kv -> Right $ convertStyle @UTF8 @HTMLStyle $ convertName kv + AndMore n -> Left n + ---------------------------------------------------------------------- -renderSeq :: PP.Pretty v - => RenderConfig -> FmtLine -> [Key] -> KVITable v -> Html () -renderSeq cfg fmt keys t = - mapM_ (flip (fmtRender fmt) Nothing) $ htmlRows keys [] +renderSeq :: Sayable "html" v + => RenderConfig -> FmtLine + -> (TblHdrs, TblHdrs) + -> KVITable v + -> Html () +renderSeq cfg fmt kmap t = + let lst = htmlRows kmap mempty + rndr = fmtRender fmt Nothing + in sequence_ (each rndr lst) where - mkVal = Val 1 False . T.pack . show . PP.pretty - htmlRows :: [Key] -> KeySpec -> [ [FmtVal] ] - htmlRows [] path = - let v = lookup path t + each = map + + filterBlank = if hideBlankRows cfg + then L.filter (not . all isNothing) + else id + + mkVal = Val Singular False False . T.pack . sez @"html" + + htmlRows :: (TblHdrs, TblHdrs) -> 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 = + row = maybe (Val Singular False False "") mkVal v + in if skip then mempty else single $ single row + htmlRows ([], colKeyMap) path = 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 - + fmap (fmap (maybe (Val Singular False False "") id)) . filterBlank + in filterOrDefaultBlankRows $ single $ multivalRows colKeyMap path + htmlRows ((key,keyvals) : kseq, colKeyMap) path = + let subrows = \case + V keyval -> htmlRows (kseq, colKeyMap) $ snoc path (key,keyval) + _ -> [ [Val (Cols nCols) True True "more"] ] + nCols = product ( nLength . snd <$> colKeyMap ) + nHdrs = nLength kseq + 1 + endOfGroup = key `elem` rowGroup cfg + genSubrows keyval = + let sr = subrows keyval + kv = toHdrText' keyval + in fst + $ foldl (leftAdd (nLength sr)) (mempty, Just kv) + $ 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' i v) = Val h (g || g') i v + setValGrouping g (Hdr h g' v) = Hdr h (g || g') v + in ( snoc acc + (case mb'kv of + Nothing -> sr + Just (Right kv) -> + let w = if rowRepeat cfg then 1 else nrows + in Hdr (Rows w) endOfGroup kv : sr + Just (Left n) -> + let m = fromString $ sez @"html" $ t'"{+" &+ n &+ '}' + in Hdr (Cols nHdrs) True m : sr + ) + , if rowRepeat cfg then mb'kv else Nothing) + in concat $ each genSubrows 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 + multivalRows ((key, keyvals) : []) path = + (\case + V v -> mkVal <$> lookup' (snoc path (key,v)) t + _ -> Just $ Val Singular False True "... -->" + ) <$> keyvals + multivalRows ((key, keyvals) : kseq) path = + concatMap (\case + V v -> multivalRows kseq (snoc path (key,v)) + _ -> mempty + ) keyvals diff --git a/src/Data/KVITable/Render/Internal.hs b/src/Data/KVITable/Render/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/KVITable/Render/Internal.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.KVITable.Render.Internal where + +import qualified Data.List as L +import Data.Name ( ConvertName, UTF8 ) +import Data.String ( fromString ) +import Numeric.Natural + +import Data.KVITable +import Data.KVITable.Internal.Helpers +import Data.KVITable.Render + + +-- TODO: to allow for hideBlankCols, the KVITable should keep track of what the +-- pre-declared vals for each key are v.s. what additional vals may be set by +-- setting a value in that region. Then there is enough information here +-- (without re-scanning the table) to properly compute the keyvals that should be +-- displayed (which would also mean that the hideCols/hideRows determinations in +-- the rendering functions below are no longer needed. + +data TblHdr = V (KeyVal) | AndMore Natural + +type TblHdrs = [ (Key, [TblHdr]) ] + +-- | Returns the rows and columns KeyVals, with appropriate application of +-- RenderConfig specifications: colStackAt, maxCells, maxCols. Does not collapse +-- empty rows or columns. + +renderingKeyVals :: RenderConfig + -> KeyVals + -> (TblHdrs, TblHdrs) +renderingKeyVals cfg inpKvs = + let maxNumKeys = maxCells cfg + origNumKeys = toEnum $ length inpKvs + maxNumCols = min (maxCells cfg) (maxCols cfg) + + in case colStackAt cfg of + Nothing -> + -- width is just keys, height is combination of keys and values + let okKvs = if origNumKeys > maxNumKeys + then snoc (take (fromEnum maxNumKeys) (fst kvs)) + (fromString + $ "{+ " <> show (origNumKeys - maxNumKeys) <> " MORE}" + , mempty + ) + else (fst kvs) + -- n.b. maxCols is not really useful here, since all but the last + -- column are headers and values are only shown in that last column. + in (snd $ trimStacked True 1 maxNumKeys okKvs, []) + Just _c -> + let (kvsRows, kvsCols) = kvs + numRegularColKvs = let v = length inpKvs - length kvsCols + in if v < 0 then error "BAD1" else toEnum v + numStackedCols = countStacked kvsCols + origNumCols = numRegularColKvs + numStackedCols + allowedNumCols = subOrDef 1 maxNumCols numRegularColKvs + okKvsCols = if origNumCols > maxNumCols + then if numStackedCols <= maxNumCols + then kvsCols + else snd $ trimStacked False 1 allowedNumCols kvsCols + else kvsCols + allowedNumRows = subOrDef 1 (maxCells cfg) + (if origNumCols > maxNumCols + then if numStackedCols <= maxNumCols + then numStackedCols + else allowedNumCols + else numStackedCols + ) + eachRowCols = min maxNumCols numStackedCols + okKvsRows = snd $ trimStacked False eachRowCols allowedNumRows kvsRows + in (okKvsRows, okKvsCols) + + where + + -- subtracting Naturals must be done carefully to not allow the result to be + -- < 0; a post-subtraction max is not enough to protect against the initial + -- value. + subOrDef d a b = if a < b then d else a - b + + kvs = let kvs' = case colStackAt cfg of + Nothing -> (inpKvs, mempty) + Just c -> span ((/= c) . fst) inpKvs + ksrt = case sortKeyVals cfg of + Nothing -> kvs' + Just fn -> fn kvs' + in ( fmap (fmap V) <$> fst ksrt + , fmap (fmap V) <$> snd ksrt + ) + + countStacked = \case -- does not allow for hiddenCols + [] -> 1 + ((_,vs):r) -> toEnum (L.length vs) * countStacked r + trimStacked _ each n [] = ((n,each), []) + trimStacked _mulSubs each n ((k,vs):[]) = + let lvs = toEnum $ length vs + mvs = foldl (\a b -> if b * each < n then b else a) 1 $ [0..lvs] + tvs = snoc (take (fromEnum mvs) vs) $ AndMore $ lvs - mvs + rvs = if mvs < lvs then tvs else vs + in ((subOrDef 0 n mvs, mvs * each), [(k,rvs)]) + trimStacked mulSubs each n ((k,vs):rkvs) = + let lvs = toEnum $ length vs + ((n',w), kvs') = trimStacked mulSubs each n rkvs + mvs = foldl (\a b -> if b * w < n then b else a) 1 $ [0..lvs] + tvs = snoc (take (fromEnum mvs) vs) $ AndMore $ remcnt (lvs - mvs) rkvs + rvs = if mvs < lvs then tvs else vs + in ((subOrDef 0 n' mvs, mvs * w), (k,rvs):kvs') + + remcnt n [] = n + remcnt n (rkv:rkvs) = n * remcnt (toEnum $ length (snd rkv)) rkvs + + +instance ConvertName UTF8 "Key" "column header" +instance ConvertName UTF8 "KeyVal" "column header" + + +nLength :: Foldable t => t a -> Natural +nLength = toEnum . length diff --git a/test/AsciiRenderTests.hs b/test/AsciiRenderTests.hs --- a/test/AsciiRenderTests.hs +++ b/test/AsciiRenderTests.hs @@ -5,6 +5,7 @@ module AsciiRenderTests where import Control.Monad ( unless ) +import Data.String ( fromString ) import Data.Text ( Text ) import qualified Data.Text as T import Lens.Micro ( (^.), (.~), (%~), (&) ) @@ -44,6 +45,7 @@ , fmap (de "∌ ") $ drop (length al) el , fmap (da "∹ ") $ drop (length el) al ]) + -- writeFile "test.txt" $ T.unpack $ T.unlines al assertFailure $ T.unpack $ T.unlines details @@ -120,7 +122,7 @@ , testCase "medium sized table render, sorted" $ cmpTables "medium table" - (KTRA.render (cfg0 { KTR.sortKeyVals = True }) mediumKVI) [sq| + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha }) mediumKVI) [sq| **** | compiler | debug | optimization | Value | +----------+-------+--------------+-------+ @@ -142,7 +144,7 @@ , testCase "medium sized table render, unsorted" $ cmpTables "medium table" - (KTRA.render (cfg0 { KTR.sortKeyVals = False }) mediumKVI) [sq| + (KTRA.render (cfg0 { KTR.sortKeyVals = Nothing }) mediumKVI) [sq| **** | compiler | debug | optimization | Value | +----------+-------+--------------+-------+ @@ -164,7 +166,7 @@ , testCase "medium table, sorted, blank, row skip, no repeats" $ cmpTables "medium table" - (KTRA.render (cfg0 { KTR.sortKeyVals = True + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.rowRepeat = False }) mediumKVI) [sq| **** | compiler | debug | optimization | Value | @@ -187,7 +189,7 @@ , testCase "medium table, sorted, blank row skip, no repeats, group unknown" $ cmpTables "medium table s 0brow 0rep [unknown]" - (KTRA.render (cfg0 { KTR.sortKeyVals = True + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.rowRepeat = False , KTR.rowGroup = ["unknown"] }) mediumKVI) [sq| @@ -212,7 +214,7 @@ , testCase "medium table, sorted, blank row skip, no repeats, group compiler" $ cmpTables "medium table s 0brow 0rep [unknown]" - (KTRA.render (cfg0 { KTR.sortKeyVals = True + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.rowRepeat = False , KTR.rowGroup = ["compiler"] }) mediumKVI) [sq| @@ -242,7 +244,7 @@ , 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 + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.rowRepeat = False , KTR.rowGroup = ["unknown", "compiler", "unk", "debug", "huh"] }) mediumKVI) [sq| @@ -275,7 +277,7 @@ , testCase "medium table, sorted, blank" $ cmpTables "medium table" - (KTRA.render (cfg0 { KTR.sortKeyVals = True + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.hideBlankRows = False }) mediumKVI) [sq| **** | compiler | debug | optimization | Value | @@ -314,7 +316,7 @@ , testCase "medium sized table render, sorted, no blank, colstack unknown" $ cmpTables "medium table s 0blnk colstk=unknown" - (KTRA.render (cfg0 { KTR.sortKeyVals = True + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.colStackAt = Just "unknown" }) mediumKVI) [sq| **** @@ -338,7 +340,7 @@ , testCase "medium sized table render, sorted, !blank, colstk optimization" $ cmpTables "medium table s 0blnk colstk=optimization" - (KTRA.render (cfg0 { KTR.sortKeyVals = True + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.hideBlankRows = True , KTR.colStackAt = Just "optimization" }) mediumKVI) [sq| @@ -357,7 +359,7 @@ , 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 + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.hideBlankRows = True , KTR.colStackAt = Just "optimization" , KTR.rowRepeat = False @@ -383,7 +385,7 @@ , testCase "medium sized table render, sorted, !blank, equisize, colstack debug" $ cmpTables "medium table s 0blnk equisize colstk=debug" - (KTRA.render (cfg0 { KTR.sortKeyVals = True + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.hideBlankRows = True , KTR.equisizedCols = True , KTR.colStackAt = Just "debug" @@ -401,7 +403,7 @@ , testCase "medium sized table render, sorted, !blank, fitsize, colstack debug" $ cmpTables "medium table s 0blnk fitsize colstk=debug" - (KTRA.render (cfg0 { KTR.sortKeyVals = True + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.hideBlankRows = True , KTR.equisizedCols = False , KTR.colStackAt = Just "debug" @@ -431,7 +433,7 @@ ] step "ASCII rendering unsorted" cmpTables "small table right aligned unsorted" - (KTRA.render (cfg0 { KTR.sortKeyVals = False }) tbl) [sq| + (KTRA.render (cfg0 { KTR.sortKeyVals = Nothing }) tbl) [sq| **** | id | name | +----+--------------+ @@ -441,7 +443,7 @@ ****|] step "ASCII rendering sorted" cmpTables "small table right aligned sorted" - (KTRA.render (cfg0 { KTR.sortKeyVals = True }) tbl) [sq| + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha }) tbl) [sq| **** | id | name | +----+--------------+ @@ -462,7 +464,7 @@ , ([("City name", "Sydney"), ("Area", "2058"), ("Population", "4336374")], 1214.8) ] in cmpTables "small table float value table" - (KTRA.render (cfg0 { KTR.sortKeyVals = True }) tbl) [sq| + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha }) tbl) [sq| **** | City name | Area | Population | Annual Rainfall | +-----------+------+------------+-----------------+ @@ -477,7 +479,7 @@ , testCase "big table grouped sorted" $ cmpTables "big table grouped sorted" - (KTRA.render (cfg0 { KTR.sortKeyVals = True + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.rowRepeat = False , KTR.rowGroup = [ "Location", "Biome", "Category" ] }) zooTable2) @@ -493,7 +495,7 @@ 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 + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.rowRepeat = False , KTR.rowGroup = [ "Location", "Biome", "Category" ] , KTR.colStackAt = Just "Name" @@ -503,7 +505,7 @@ , testCase "big table grouped sorted equisized" $ cmpTables "big table grouped sorted equisized" - (KTRA.render (cfg0 { KTR.sortKeyVals = True + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.rowRepeat = False , KTR.hideBlankCols = False , KTR.equisizedCols = True @@ -531,7 +533,7 @@ , testCase "big table grouped sorted fitsize colstack=ghcver" $ cmpTables "big table grouped sorted fitsize colstack=ghcver" - (KTRA.render (cfg0 { KTR.sortKeyVals = True + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.rowRepeat = False , KTR.hideBlankCols = False , KTR.equisizedCols = False @@ -559,7 +561,7 @@ , testCase "big table grouped sorted fitsize colstack=Strategy" $ cmpTables "big table grouped sorted fitsize colstack=Strategy" - (KTRA.render (cfg0 { KTR.sortKeyVals = True + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.rowRepeat = False , KTR.hideBlankCols = False , KTR.equisizedCols = False @@ -585,7 +587,7 @@ , testCase "nested table hide=blankRows,blankCols colstack=ones" $ cmpTables "nested table hide=blankRows,blankCols colstack=ones" - (KTRA.render (cfg0 { KTR.sortKeyVals = True + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.rowRepeat = False , KTR.hideBlankCols = True , KTR.hideBlankRows = True @@ -618,7 +620,7 @@ , testCase "nested table colstack=tens" $ cmpTables "nested table colstack=tens" - (KTRA.render (cfg0 { KTR.sortKeyVals = True + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.rowRepeat = False , KTR.hideBlankCols = True , KTR.hideBlankRows = True @@ -655,7 +657,7 @@ , testCase "nested table hide=blankCols,blankRows colstack=hundreds" $ cmpTables "nested table hide-blankCols,blankRows colstack=hundreds" - (KTRA.render (cfg0 { KTR.sortKeyVals = True + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.rowRepeat = False , KTR.hideBlankCols = True , KTR.hideBlankRows = True @@ -666,7 +668,7 @@ , testCase "nested table hide=none colstack=hundreds" $ cmpTables "nested table hide=none colstack=hundreds" - (KTRA.render (cfg0 { KTR.sortKeyVals = True + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.rowRepeat = False , KTR.hideBlankCols = False , KTR.hideBlankRows = False @@ -675,9 +677,32 @@ }) nestedTable) [uq_f|examples/hundreds_all.md|] + , testCase "nested table hide=none colstack=hundreds testfile" $ + cmpTables "nested table hide=none colstack=hundreds testfile" + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha + , KTR.rowRepeat = False + , KTR.hideBlankCols = False + , KTR.hideBlankRows = False + , KTR.equisizedCols = False + , KTR.colStackAt = Just "hundreds" + }) nestedTable) + [sq_f|test/evenodd.md|] + + , testCase "nested table hide=none colstack=hundreds, maxCells=60" $ + cmpTables "nested table hide=none colstack=hundreds, maxCells=60" + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha + , KTR.rowRepeat = False + , KTR.hideBlankCols = False + , KTR.hideBlankRows = False + , KTR.equisizedCols = False + , KTR.colStackAt = Just "hundreds" + , KTR.maxCells = 60 + }) nestedTable) + [sq3_f|test/evenodd.md|] + , testCase "nested table hide=none colstack=hundreds equisized" $ cmpTables "nested table hide=none colstack=hundreds equisized" - (KTRA.render (cfg0 { KTR.sortKeyVals = True + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.rowRepeat = False , KTR.hideBlankCols = False , KTR.hideBlankRows = False @@ -688,7 +713,7 @@ , testCase "nested table hideBlank=rol,col colstack=thousands" $ cmpTables "nested table hideBlank=row,col colstack=thousands" - (KTRA.render (cfg0 { KTR.sortKeyVals = True + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.rowRepeat = False , KTR.hideBlankCols = True , KTR.hideBlankRows = True @@ -699,7 +724,7 @@ , testCase "nested table hideBlank=rol,col" $ cmpTables "nested table hideBlank=row,col" - (KTRA.render (cfg0 { KTR.sortKeyVals = True + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.rowRepeat = False , KTR.hideBlankCols = True , KTR.hideBlankRows = True @@ -707,9 +732,20 @@ }) nestedTable) [uq3_f|README.md|] + , testCase "nested table hideBlank=rol,col, maxCells=60" $ + cmpTables "nested table hideBlank=row,col, maxCells=60" + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha + , KTR.rowRepeat = False + , KTR.hideBlankCols = True + , KTR.hideBlankRows = True + , KTR.equisizedCols = False + , KTR.maxCells = 60 + }) nestedTable) + [sq5_f|test/evenodd.md|] + , testCase "nested table hideBlank=none" $ cmpTables "nested table hideBlank=none" - (KTRA.render (cfg0 { KTR.sortKeyVals = True + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.rowRepeat = False , KTR.hideBlankCols = False , KTR.hideBlankRows = False @@ -829,4 +865,30 @@ | | | | | 1 | odd | ****|] + + , testCase "big square table, numCols and numCells limited" $ + let tbl = foldl KVI.foldlInsert + (mempty & KVI.valueColName .~ "Hits" + & KVI.keyVals + .~ [ ("Pitcher", [ fromString ("P" <> show n) + | n <- [0..100::Int] ]) + , ("Batter", [ fromString ("B" <> show n) + | n <- [0..100::Int] ]) + ]) + [ ([ ("Pitcher", fromString ("P" <> show p)) + , ("Batter", fromString ("B" <> show b)) + ], p * b) + | p <- [0..100::Int] + , b <- [0..100::Int] + ] + in cmpTables "big table grouped sorted no-subtype colstack" + (KTRA.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha + , KTR.rowRepeat = False + , KTR.rowGroup = [ "Location", "Biome", "Category" ] + , KTR.colStackAt = Just "Batter" + , KTR.equisizedCols = False + , KTR.maxCols = 20 + , KTR.maxCells = 600 + }) tbl) + [sq_f|test/bigsquare.md|] ] diff --git a/test/HTMLRenderTests.hs b/test/HTMLRenderTests.hs --- a/test/HTMLRenderTests.hs +++ b/test/HTMLRenderTests.hs @@ -6,6 +6,7 @@ import Control.Monad ( unless ) import qualified Data.List as L +import Data.String ( fromString ) import Data.Text ( Text ) import qualified Data.Text as T import qualified Data.Text.Lazy as TL @@ -55,6 +56,7 @@ , fmap (de "∌ ") $ drop (length al) el , fmap (da "∹ ") $ drop (length el) al ]) + -- writeFile "test.html" $ T.unpack $ T.unlines al assertFailure $ T.unpack $ T.unlines details @@ -71,7 +73,7 @@ ****
LocationBiomeCategoryDietBearGiraffeHippoLionPenguinRhino
Location
Biome
Category
Diet
Bear
Giraffe
Hippo
Lion
Penguin
Rhino
  ←Name
LAJungleAnimalHerbivore
LA
Jungle
Animal
Herbivore
 @@ -260,9 +260,9 @@
SavannahAnimalCarnivore
Savannah
Animal
Carnivore
 @@ -276,7 +276,7 @@
Herbivore
Herbivore
 23
MiamiPolarBirdCarnivore
Miami
Polar
Bird
Carnivore
 @@ -306,9 +306,9 @@
SavannahAnimalCarnivore
Savannah
Animal
Carnivore
 @@ -322,7 +322,7 @@
Herbivore
Herbivore
 3
New YorkSavannahAnimalCarnivore
New York
Savannah
Animal
Carnivore
 @@ -353,10 +353,10 @@
San DiegoJungleAnimalOmnivore
San Diego
Jungle
Animal
Omnivore
 1
PlainsAnimalOmnivore
Plains
Animal
Omnivore
 2
PolarAnimalOmnivore
Polar
Animal
Omnivore
 1
BirdCarnivore
Bird
Carnivore
 @@ -417,9 +417,9 @@
SavannahAnimalCarnivore
Savannah
Animal
Carnivore
- + @@ -85,7 +87,7 @@ ****
Value
Value
- + @@ -103,9 +105,9 @@
Value
Value
- - - + + + @@ -116,7 +118,7 @@ , testCase "nested table hideBlank=rows,cols, fitted, colstack=hundreds" $ cmpTables "nested table hideBlank=rows,cols, fitted, colstack=hundreds" - (KTRH.render (cfg0 { KTR.sortKeyVals = True + (KTRH.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.rowRepeat = False , KTR.hideBlankCols = True , KTR.hideBlankRows = True @@ -127,7 +129,7 @@ , testCase "nested table hide=none, fitted, colstack=hundreds" $ cmpTables "nested table hide=none, fitted, colstack=hundreds" - (KTRH.render (cfg0 { KTR.sortKeyVals = True + (KTRH.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.rowRepeat = False , KTR.hideBlankCols = False , KTR.hideBlankRows = False @@ -136,9 +138,48 @@ }) nestedTable) [sq_f|examples/hundreds_all.md|] + -- duplication of the above in test/evenodd.md + , testCase "nested table hide=none, fitted, colstack=hundreds" $ + do + cmpTables "nested table hide=none, fitted, colstack=hundreds" + (KTRH.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha + , KTR.rowRepeat = False + , KTR.hideBlankCols = False + , KTR.hideBlankRows = False + , KTR.equisizedCols = False + , KTR.colStackAt = Just "hundreds" + }) nestedTable) + [sq2_f|test/evenodd.md|] + + , testCase "nested table hide=none, fitted, colstack=hundreds, maxCells=60" $ + do + cmpTables "nested table hide=none, fitted, colstack=hundreds, maxCells=60" + (KTRH.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha + , KTR.rowRepeat = False + , KTR.hideBlankCols = False + , KTR.hideBlankRows = False + , KTR.equisizedCols = False + , KTR.colStackAt = Just "hundreds" + , KTR.maxCells = 60 + }) nestedTable) + [sq4_f|test/evenodd.md|] + + , testCase "nested table hide=none, fitted, no colstack, maxCells=60" $ + do + cmpTables "nested table hide=none, fitted, no colstack, maxCells=60" + (KTRH.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha + , KTR.rowRepeat = False + , KTR.hideBlankCols = False + , KTR.hideBlankRows = False + , KTR.equisizedCols = False + , KTR.colStackAt = Nothing + , KTR.maxCells = 60 + }) nestedTable) + [sq6_f|test/evenodd.md|] + , testCase "nested table hideBlank=rol,col colstack=thousands" $ cmpTables "nested table hideBlank=row,col colstack=thousands" - (KTRH.render (cfg0 { KTR.sortKeyVals = True + (KTRH.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.rowRepeat = False , KTR.hideBlankCols = True , KTR.hideBlankRows = True @@ -149,7 +190,7 @@ , testCase "nested table hideBlank=rol,col" $ cmpTables "nested table hideBlank=row,col" - (KTRH.render (cfg0 { KTR.sortKeyVals = True + (KTRH.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.rowRepeat = False , KTR.hideBlankCols = True , KTR.hideBlankRows = True @@ -160,7 +201,7 @@ , testCase "big table grouped sorted" $ cmpTables "big table grouped sorted" - (KTRH.render (cfg0 { KTR.sortKeyVals = True + (KTRH.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.rowRepeat = False , KTR.rowGroup = [ "Location", "Biome", "Category" ] }) zooTable2) @@ -176,7 +217,7 @@ 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 + (KTRH.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha , KTR.rowRepeat = False , KTR.rowGroup = [ "Location", "Biome", "Category" ] , KTR.colStackAt = Just "Name" @@ -184,5 +225,29 @@ }) zt) [sq2_f|examples/zoo.md|] - + , testCase "big square table, numCols and numCells limited" $ + let tbl = foldl KVI.foldlInsert + (mempty & KVI.valueColName .~ "Hits" + & KVI.keyVals + .~ [ ("Pitcher", [ fromString ("P" <> show n) + | n <- [0..100::Int] ]) + , ("Batter", [ fromString ("B" <> show n) + | n <- [0..100::Int] ]) + ]) + [ ([ ("Pitcher", fromString ("P" <> show p)) + , ("Batter", fromString ("B" <> show b)) + ], p * b) + | p <- [0..100::Int] + , b <- [0..100::Int] + ] + in cmpTables "big table grouped sorted no-subtype colstack" + (KTRH.render (cfg0 { KTR.sortKeyVals = Just KTR.sortNumericAlpha + , KTR.rowRepeat = False + , KTR.rowGroup = [ "Location", "Biome", "Category" ] + , KTR.colStackAt = Just "Batter" + , KTR.equisizedCols = False + , KTR.maxCols = 20 + , KTR.maxCells = 600 + }) tbl) + [sq2_f|test/bigsquare.md|] ] diff --git a/test/SampleTables.hs b/test/SampleTables.hs --- a/test/SampleTables.hs +++ b/test/SampleTables.hs @@ -3,6 +3,7 @@ module SampleTables where import Data.KVITable +import Data.String ( fromString ) import Data.Text ( Text ) import qualified Data.Text as T import Lens.Micro ( (^.), (.~), (%~), (&) ) @@ -195,11 +196,11 @@ , ("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)] + [ let keyvals = [("millions", fromString $ show m) + ,("thousands", fromString $ show t) + ,("hundreds", fromString $ show h) + ,("tens", fromString $ show d) + ,("ones", fromString $ show o)] value = if (o `rem` 2) == 1 then "odd" else "even" in (keyvals, value) | m <- [0..2 :: Int] diff --git a/test/TestMain.hs b/test/TestMain.hs --- a/test/TestMain.hs +++ b/test/TestMain.hs @@ -165,6 +165,18 @@ , ([ "baz", "beam", "woof"], "yo") ] + , testCaseSteps "insertWith" $ \step -> + do + let keyvals = [ ("foo", "bar"), ("moo", "cow") ] + + step "inserting a new value" + let t1 = insertWith (<>) keyvals "old" kvi0 + Just "old" @=? lookup keyvals t1 + + step "combining with an existing value" + let t2 = insertWith (<>) keyvals "new" t1 + Just "newold" @=? lookup keyvals t2 + , testCase "medium sized table rows" $ rows mediumKVI @?= [ ([ "gcc7", "yes", "0"], "good" ) diff --git a/test/TestQQDefs.hs b/test/TestQQDefs.hs --- a/test/TestQQDefs.hs +++ b/test/TestQQDefs.hs @@ -13,6 +13,9 @@ sq_f = quoteFile sq sq2_f = quoteFile $ qqExtractor 2 "\n****" sq3_f = quoteFile $ qqExtractor 3 "\n****" +sq4_f = quoteFile $ qqExtractor 4 "\n****" +sq5_f = quoteFile $ qqExtractor 5 "\n****" +sq6_f = quoteFile $ qqExtractor 6 "\n****" uq :: QuasiQuoter uq = qqExtractor 1 "\n____"
foodogValue
foo
dog
Value