diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Revision history for KVITable +## 1.0 3.0 -- 2024-02-22 + +* Support GHC 9.8. +* Internal updates to confirm safety and avoid partial functions. + ## 1.0.2.0 -- 2023-01-09 * Support GHC 9.4. 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.2.1 +version: 1.0.3.0 synopsis: Key/Value Indexed Table container and formatting library description: . @@ -53,7 +53,7 @@ , Data.KVITable.Render.ASCII , Data.KVITable.Render.HTML -- other-modules: - build-depends: base >=4.12 && <4.19 + build-depends: base >=4.12 && <4.20 , containers , lucid >= 2.9 && < 2.12 , microlens >= 0.4 && < 0.5 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,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -74,14 +75,14 @@ data FmtVal = Separator | TxtVal Text | CenterVal Text fmtRender :: FmtLine -> [FmtVal] -> Text -fmtRender (FmtLine [] _sigils _sepsigils) [] = "" -fmtRender (FmtLine cols sigils sepsigils) vals = +fmtRender (FmtLine _cols _sigils _sepsigils) [] = "" +fmtRender (FmtLine cols sigils sepsigils) vals@(val:_) = 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 + l = sig sep val in l <> T.concat [ sig pad fld <> @@ -123,7 +124,9 @@ [ fmtRender lastFmt (replicate (fmtColCnt lastFmt) Separator) ]) where hrows = hdrstep cfg t keys - lastFmt = if null hrows then fmtLine [] else hdrFmt $ head $ reverse hrows + lastFmt = case reverse hrows of + [] -> fmtLine [] + (hrow:_) -> hdrFmt hrow hdrstep :: PP.Pretty v => RenderConfig -> KVITable v -> [Key] -> [HeaderLine] hdrstep _cfg t [] = @@ -167,13 +170,16 @@ 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) + 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 + ] + then (0, 0) + else (hl, sv) in fmap (uncurry max . subW) subTtlHdrs rsz_extsubhdrs = fmap hdrJoin $ L.transpose $ @@ -220,12 +226,13 @@ 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 + 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) ], 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 @@ -18,6 +18,8 @@ import qualified Data.Foldable as F 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.Text ( Text ) import qualified Data.Text as T @@ -117,34 +119,34 @@ 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 - ]) +renderHdrs cfg t keys = ( rowfmt, sequence_ hdrs ) where + hdrs = fmap renderHdr hrows (hrows, rowfmt) = hdrstep cfg t keys + renderHdr (HdrLine fmt hdrvals trailer) = fmtRender fmt hdrvals trailer hdrstep :: PP.Pretty v - => RenderConfig -> KVITable v -> [Key] -> ([HeaderLine], FmtLine) + => RenderConfig -> KVITable v -> [Key] + -> (NEL.NonEmpty HeaderLine, FmtLine) hdrstep _cfg t [] = - ( [ HdrLine (FmtLine [1]) [Hdr 1 False $ t ^. valueColName] Nothing ] + ( 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 + let (nexthdr0 :| nexthdrs, lowestfmt) = hdrstep cfg t keys + (HdrLine fmt vals tr) = nexthdr0 fmt' = fmtAddColLeft 1 fmt - val = Hdr (length nexthdrs) False key - in ( (HdrLine fmt' (val : vals) tr) : tail nexthdrs + val = Hdr (length nexthdrs + 1) False key + in ( (HdrLine fmt' (val : vals) tr) :| nexthdrs , fmtAddColLeft 1 lowestfmt ) hdrvalstep :: PP.Pretty v => RenderConfig -> KVITable v -> KeySpec -> [Key] - -> ([HeaderLine], FmtLine) + -> (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 @@ -157,25 +159,40 @@ then 0 else 1 fmt = FmtLine $ fmap cwidth titles - in ( [ HdrLine fmt (Hdr 1 False <$> titles) (Just key) ], fmt) + 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)) + 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)) ----------------------------------------------------------------------