From: Julien Moutinho Date: Mon, 22 Aug 2022 19:47:27 +0000 (+0200) Subject: wip X-Git-Url: https://git.sourcephile.fr/haskell/literate-accounting.git/commitdiff_plain wip --- diff --git a/flake.lock b/flake.lock index 05a7281..4a16d0b 100644 --- a/flake.lock +++ b/flake.lock @@ -2,11 +2,12 @@ "nodes": { "nixpkgs": { "locked": { - "lastModified": 1635110579, - "narHash": "sha256-QJzT/ts3reR1wtezw6/05lOur2BhF8ec1IsD7PQ1yEs=", - "path": "/nix/store/glj84wssk3gf3dqz9jr5y0x7i77p2yv0-source", - "rev": "6b23e8fc7820366e489377b5b00890f088f36a01", - "type": "path" + "lastModified": 1650076401, + "narHash": "sha256-QGxadqKWICchuuLIF2QwmHPVaUk+qO33ml5p1wW4IyA=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "75ad56bdc927f3a9f9e05e3c3614c4c1fcd99fcb", + "type": "github" }, "original": { "id": "nixpkgs", diff --git a/flake.nix b/flake.nix index dd6cf08..dde9aae 100644 --- a/flake.nix +++ b/flake.nix @@ -8,6 +8,14 @@ outputs = inputs: let pkgs = inputs.nixpkgs.legacyPackages.${system}; haskellPackages = pkgs.haskellPackages.extend (with pkgs.haskell.lib; hfinal: hsuper: { ${pkg} = buildFromSdist (hsuper.callCabal2nix pkg ./. {}); + #hakyll = hself.callHackage "hakyll" "4.13.4.1" {}; + ##hakyll-sass = unmarkBroken hsuper.hakyll-sass; + #hakyll-sass = hself.callHackage "hakyll-sass" "0.2.4" {}; + ## hakyll 4.13.4 requires pandoc 2.10 + #pandoc = hself.callHackage "pandoc" "2.10.1" {}; + #pandoc-types = hself.callHackage "pandoc-types" "1.21" {}; + #skylighting = hself.callHackage "skylighting" "0.8.5" {}; + #skylighting-core = hself.callHackage "skylighting-core" "0.8.5" {}; }); }); in { diff --git a/fourmolu.yaml b/fourmolu.yaml index 95c8107..e7453cd 100644 --- a/fourmolu.yaml +++ b/fourmolu.yaml @@ -1,7 +1,7 @@ comma-style: leading diff-friendly-import-export: true haddock-style: multi-line -indent-wheres: false +indent-wheres: true indentation: 2 newlines-between-decls: 1 record-brace-space: false diff --git a/src/Literate/Accounting/Chart.hs b/src/Literate/Accounting/Chart.hs index 848d775..ba38287 100644 --- a/src/Literate/Accounting/Chart.hs +++ b/src/Literate/Accounting/Chart.hs @@ -39,37 +39,37 @@ instance (Show k, Show a) => Show (Chart k a) where showChartAsTree :: Show k => Show a => Chart k a -> String showChartAsTree = List.unlines . drawMap - where - -- drawNode :: (k, (a, Chart k a)) -> [String] - drawNode (k, (a, ts0)) = - List.zipWith - (<>) - (List.lines (showsPrec 11 k "")) - (List.lines (" " <> showsPrec 11 a "") <> List.repeat "") - <> drawMap ts0 - drawMap = go . Map.toList . unChart - where - go [] = [] - go [t] = shift "` " " " (drawNode t) - go (t : ts) = shift "+ " "| " (drawNode t) <> go ts - shift ind0 ind = List.zipWith (<>) (ind0 : List.repeat ind) + where + -- drawNode :: (k, (a, Chart k a)) -> [String] + drawNode (k, (a, ts0)) = + List.zipWith + (<>) + (List.lines (showsPrec 11 k "")) + (List.lines (" " <> showsPrec 11 a "") <> List.repeat "") + <> drawMap ts0 + drawMap = go . Map.toList . unChart + where + go [] = [] + go [t] = shift "` " " " (drawNode t) + go (t : ts) = shift "+ " "| " (drawNode t) <> go ts + shift ind0 ind = List.zipWith (<>) (ind0 : List.repeat ind) table :: [[String]] -> String -table cells = List.unlines ((\row -> List.foldr (\cell acc -> "|" <> cell <> acc) "|" row) <$> rows) - where - maxCols :: Int - maxWidths :: [Int] -- for each row - rows :: [[String]] - (maxCols, maxWidths, rows) = List.foldr go (0, List.repeat 0, []) cells +table cells = List.unlines (List.foldr (\cell acc -> "|" <> cell <> acc) "|" <$> rows) + where + maxCols :: Int + maxWidths :: [Int] -- for each row + rows :: [[String]] + (maxCols, maxWidths, rows) = List.foldr go (0, List.repeat 0, []) cells - go :: [String] -> (Int, [Int], [[String]]) -> (Int, [Int], [[String]]) - go row (accMaxCols, accMaxWidths, accRows) = - ( max accMaxCols (List.length row) - , List.zipWith max accMaxWidths (List.map List.length row <> List.repeat 0) - , List.take maxCols (List.zipWith alignLeft row maxWidths) : accRows - ) - alignRight cell maxWidth = List.replicate (maxWidth - List.length cell) ' ' <> cell - alignLeft cell maxWidth = List.take maxWidth $ cell <> List.repeat ' ' + go :: [String] -> (Int, [Int], [[String]]) -> (Int, [Int], [[String]]) + go row (accMaxCols, accMaxWidths, accRows) = + ( max accMaxCols (List.length row) + , List.zipWith max accMaxWidths (List.map List.length row <> List.repeat 0) + , List.take maxCols (List.zipWith alignLeft row maxWidths) : accRows + ) + alignRight cell maxWidth = List.replicate (maxWidth - List.length cell) ' ' <> cell + alignLeft cell maxWidth = List.take maxWidth $ cell <> List.repeat ' ' {- >>> error $ table [["toto", "titi"], ["123", "4", "567890"], ["", "", "0"]] |toto|titi| @@ -124,22 +124,22 @@ using @merge value oldValue@ in case @path@ already map to an @oldValue@. -} insert :: Ord k => a -> (a -> a -> a) -> ChartPath k -> a -> Chart k a -> Chart k a insert init merge p a ch = go ch p - where - go (Chart m) = \case - k :| [] -> - Chart $ - Map.insertWith - (\_new (old, c) -> (merge a old, c)) - k - (a, empty) - m - k :| k1 : ks -> - Chart $ - Map.insertWith - (\_new (old, c) -> (old, go c (k1 :| ks))) - k - (init, go empty (k1 :| ks)) - m + where + go (Chart m) = \case + k :| [] -> + Chart $ + Map.insertWith + (\_new (old, c) -> (merge a old, c)) + k + (a, empty) + m + k :| k1 : ks -> + Chart $ + Map.insertWith + (\_new (old, c) -> (old, go c (k1 :| ks))) + k + (init, go empty (k1 :| ks)) + m -- | Return the value (if any) associated with the given 'Path'. lookup :: Ord k => ChartPath k -> Chart k a -> Maybe a @@ -184,21 +184,21 @@ flatten = flattenWithPath . const flattenWithPath :: Ord k => ([k] -> x -> y) -> Chart k x -> Map (ChartPath k) y flattenWithPath = go [] - where - go p f ch = - Map.unions $ - Map.mapKeysMonotonic - (NonEmpty.reverse . flip (:|) p) - ( Map.mapWithKey - ( \k (a, _children) -> - f (List.reverse (k : p)) a - ) - (unChart ch) - ) : - Map.foldrWithKey - (\k (_a, children) -> (go (k : p) f children :)) - [] - (unChart ch) + where + go p f ch = + Map.unions $ + Map.mapKeysMonotonic + (NonEmpty.reverse . flip (:|) p) + ( Map.mapWithKey + ( \k (a, _children) -> + f (List.reverse (k : p)) a + ) + (unChart ch) + ) : + Map.foldrWithKey + (\k (_a, children) -> (go (k : p) f children :)) + [] + (unChart ch) mapByDepthFirst :: Ord k => (Chart k b -> a -> b) -> Chart k a -> Chart k b mapByDepthFirst f = @@ -209,26 +209,26 @@ mapByDepthFirst f = foldrPath :: Ord k => (ChartPath k -> a -> acc -> acc) -> ChartPath k -> Chart k a -> acc -> acc foldrPath f = go [] . NonEmpty.toList - where - go _ [] _m acc = acc - go p (k : ks) (Chart m) acc = - case Map.lookup k m of - Just (a, ch) -> f (NonEmpty.reverse (k :| p)) a $ go (k : p) ks ch acc - Nothing -> acc + where + go _ [] _m acc = acc + go p (k : ks) (Chart m) acc = + case Map.lookup k m of + Just (a, ch) -> f (NonEmpty.reverse (k :| p)) a $ go (k : p) ks ch acc + Nothing -> acc foldrWithPath :: Ord k => (ChartPath k -> a -> acc -> acc) -> acc -> Chart k a -> acc foldrWithPath f = go [] - where - go p acc = - Map.foldrWithKey - ( \k (a, ch) acc' -> - f - (NonEmpty.reverse (k :| p)) - a - (go (k : p) acc' ch) - ) - acc - . unChart + where + go p acc = + Map.foldrWithKey + ( \k (a, ch) acc' -> + f + (NonEmpty.reverse (k :| p)) + a + (go (k : p) acc' ch) + ) + acc + . unChart -- * Type 'ChartM' -- | A 'Monad' to construct a 'Chart'. diff --git a/src/Literate/Box.hs b/src/Literate/Box.hs index 5a5e532..78bb9e7 100644 --- a/src/Literate/Box.hs +++ b/src/Literate/Box.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + {- | Module : Text.PrettyPrint.Boxes Copyright : (c) Brent Yorgey 2009 @@ -12,34 +14,14 @@ module Literate.Box where import Control.Arrow (first, (***)) -import Data.Foldable (Foldable (foldr), toList) +import Data.Foldable (toList) import Data.List (foldl', intersperse) -import Data.String (IsString (..), unwords, words) +import Data.String (IsString (..)) import Prelude hiding (Word, (<>)) -- Use the build from GHC.Exts because GHC has some rules that make it faster. import GHC.Exts (build) -{- | @'chunksOf' n@ splits a list into length-n pieces. The last - piece will be shorter if @n@ does not evenly divide the length of - the list. If @n <= 0@, @'chunksOf' n l@ returns an infinite list - of empty lists. For example: - - Note that @'chunksOf' n []@ is @[]@, not @[[]]@. This is - intentional, and is consistent with a recursive definition of - 'chunksOf'; it satisfies the property that - - @chunksOf n xs ++ chunksOf n ys == chunksOf n (xs ++ ys)@ - - whenever @n@ evenly divides the length of @xs@. --} -chunksOf :: Int -> [e] -> [[e]] -chunksOf i ls = map (take i) (build (splitter ls)) - where - splitter :: [e] -> ([e] -> a -> a) -> a -> a - splitter [] _ n = n - splitter l c n = l `c` splitter (drop i l) c n - {- | The basic data type. A box has a specified size and some sort of contents. -} @@ -64,20 +46,19 @@ data Content SubBox Alignment Alignment Box deriving (Show) --- | Convenient ability to use bare string literals as boxes. instance IsString Box where - fromString = text + fromString t = Box 1 (length t) (Text t) -- | Data type for specifying the alignment of boxes. data Alignment = -- | Align at the top/left. AlignTopLeft | -- | Centered, biased to the top/left. - AlignCenter1 + AlignTopLeftCenter | -- | Centered, biased to the bottom/right. - AlignCenter2 + AlignBottomRightCenter | -- | Align at the bottom/right. - AlignLast + AlignBottomRight deriving (Eq, Read, Show) {- | The null box, which has no content and no size. It is quite @@ -98,10 +79,6 @@ emptyBox r c = Box r c Blank char :: Char -> Box char c = Box 1 1 (Text [c]) --- | A (@1 x len@) box containing a string of length @len@. -text :: String -> Box -text t = Box 1 (length t) (Text t) - {- | Paste two boxes together horizontally, using a default (top) alignment. -} @@ -178,6 +155,11 @@ punctuateV a p bs = vcat a (intersperse p (toList bs)) {- | @para algn w t@ is a box of width @w@, containing text @t@, aligned according to @algn@, flowed to fit within the given width. +>>> para AlignTopLeft 10 "12 34 56 78 9 10 11 12" +Box {rows = 3, cols = 10, content = SubBox AlignTopLeft AlignTopLeft (Box {rows = 3, cols = 10, content = Col +[Box {rows = 1, cols = 10, content = SubBox AlignTopLeft AlignTopLeft (Box {rows = 1, cols = 8, content = Text "12 34 56"})} +,Box {rows = 1, cols = 10, content = SubBox AlignTopLeft AlignTopLeft (Box {rows = 1, cols = 10, content = Text "78 9 10 11"})} +,Box {rows = 1, cols = 10, content = SubBox AlignTopLeft AlignTopLeft (Box {rows = 1, cols = 2, content = Text "12"})}]})} -} para :: Alignment -> Int -> String -> Box para a n t = (\ss -> mkParaBox a (length ss) ss) $ flow n t @@ -185,65 +167,104 @@ para a n t = (\ss -> mkParaBox a (length ss) ss) $ flow n t {- | @columns w h t@ is a list of boxes, each of width @w@ and height at most @h@, containing text @t@ flowed into as many columns as necessary. +>>> error $ render $ hcat AlignTopLeft $ columns AlignTopLeft 10 5 "1 2 3 4 5 6 7 8 9 10 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29" +1 2 3 4 5 21 22 23 +6 7 8 9 1024 25 26 +12 13 14 27 28 29 +15 16 17 +18 19 20 -} columns :: Alignment -> Int -> Int -> String -> [Box] columns a w h t = map (mkParaBox a h) . chunksOf h $ flow w t +{- | @'chunksOf' n@ splits a list into length-n pieces. The last + piece will be shorter if @n@ does not evenly divide the length of + the list. If @n <= 0@, @'chunksOf' n l@ returns an infinite list + of empty lists. For example: + + Note that @'chunksOf' n []@ is @[]@, not @[[]]@. This is + intentional, and is consistent with a recursive definition of + 'chunksOf'; it satisfies the property that + + @chunksOf n xs ++ chunksOf n ys == chunksOf n (xs ++ ys)@ + + whenever @n@ evenly divides the length of @xs@. +-} +chunksOf :: Int -> [e] -> [[e]] +chunksOf i ls = map (take i) (build (splitter ls)) + where + splitter :: [e] -> ([e] -> a -> a) -> a -> a + splitter [] _ n = n + splitter l c n = l `c` splitter (drop i l) c n + {- | @mkParaBox a n s@ makes a box of height @n@ with the text @s@ aligned according to @a@. -} mkParaBox :: Alignment -> Int -> [String] -> Box -mkParaBox a n = alignVert AlignTopLeft n . vcat a . map text +mkParaBox a n = alignVert AlignTopLeft n . vcat a . map fromString + +{- | Flow the given text into the given width. +>>> flow 10 "1234567890abc abcdefghijkl" +["1234567890","abcdefghij"] --- | Flow the given text into the given width. +>>> flow 10 "1234567890abcdefghij" +["1234567890"] +-} flow :: Int -> String -> [String] flow n t = - map (take n) - . getLines - $ foldl' addWordP (emptyPara n) (map mkWord . words $ t) + (take n <$>) . getLines $ + foldl' addWordP (emptyPara n) (fromString <$> words t) +-- * Type 'Para' data Para = Para { paraWidth :: Int - , paraContent :: ParaContent + , unPara :: ParaContent } -data ParaContent = Block - { fullLines :: [Line] - , lastLine :: Line +data ParaContent = ParaContent + { paraLines :: [Line] + , paraLastLine :: Line } emptyPara :: Int -> Para -emptyPara pw = Para pw (Block [] (Line 0 [])) +emptyPara pw = Para pw (ParaContent [] (Line 0 [])) getLines :: Para -> [String] -getLines (Para _ (Block ls l)) - | lLen l == 0 = process ls +getLines (Para _ (ParaContent ls l)) + | lineLen l == 0 = process ls | otherwise = process (l : ls) where - process = map (unwords . reverse . map getWord . getWords) . reverse - -data Line = Line {lLen :: Int, getWords :: [Word]} + process = map (unwords . reverse . map unWord . unLine) . reverse +-- ** Type 'Line' +data Line = Line + { lineLen :: Int + , unLine :: [Word] + } mkLine :: [Word] -> Line -mkLine ws = Line (sum (map ((+ 1) . wLen) ws) - 1) ws +mkLine ws = Line (sum (map ((+ 1) . wordLen) ws) - 1) ws startLine :: Word -> Line startLine = mkLine . (: []) -data Word = Word {wLen :: Int, getWord :: String} +-- ** Type 'Word +data Word = Word + { wordLen :: Int + , unWord :: String + } -mkWord :: String -> Word -mkWord w = Word (length w) w +instance IsString Word where + fromString w = Word (length w) w addWordP :: Para -> Word -> Para -addWordP (Para pw (Block fl l)) w - | wordFits pw w l = Para pw (Block fl (addWordL w l)) - | otherwise = Para pw (Block (l : fl) (startLine w)) +addWordP (Para pw (ParaContent fl l)) w + | wordFits pw w l = Para pw (ParaContent fl (addWordL w l)) + | otherwise = Para pw (ParaContent (l : fl) (startLine w)) addWordL :: Word -> Line -> Line -addWordL w (Line len ws) = Line (len + wLen w + 1) (w : ws) +addWordL w (Line len ws) = Line (len + wordLen w + 1) (w : ws) wordFits :: Int -> Word -> Line -> Bool -wordFits pw w l = lLen l == 0 || lLen l + wLen w + 1 <= pw +wordFits pw w l = lineLen l == 0 || lineLen l + wordLen w + 1 <= pw -------------------------------------------------------------------------------- -- Alignment ----------------------------------------------------------------- @@ -259,7 +280,34 @@ alignHoriz a c b = align a AlignTopLeft (rows b) c b {- | @alignVert algn n bx@ creates a box of height @n@, with the contents and width of @bx@, vertically aligned according to @algn@. +>>> error $ render $ alignVert AlignTopLeft 4 "123" +123 + + + + +>>> error $ render $ alignVert AlignBottomRight 4 "123" + + + +123 + -} +-- | >>> error $ render $ alignVert AlignBottomRightCenter 4 "123" +-- +-- +-- 123 +-- +-- +-- +-- 123 +-- +-- | >>> error $ render $ alignVert AlignTopLeftCenter 4 "123" +-- +-- 123 +-- +-- + alignVert :: Alignment -> Int -> Box -> Box alignVert a r b = align AlignTopLeft a r (cols b) b @@ -280,22 +328,35 @@ moveUp n b = alignVert AlignTopLeft (rows b + n) b aligned to the bottom. See the disclaimer for 'moveLeft'. -} moveDown :: Int -> Box -> Box -moveDown n b = alignVert AlignLast (rows b + n) b +moveDown n b = alignVert AlignBottomRight (rows b + n) b {- | Move a box left by putting it in a larger box with extra columns, aligned left. Note that the name of this function is something of a white lie, as this will only result in the box being moved left by the specified amount if it is already in a larger right-aligned context. + +>>> error $ render $ moveLeft 4 "123" +123 + +>>> error $ render $ alignHoriz AlignBottomRight 20 $ moveLeft 15 "123" + 123 + +>>> error $ render $ alignHoriz AlignTopLeft 10 $ moveLeft 15 "123" +123 + -} moveLeft :: Int -> Box -> Box moveLeft n b = alignHoriz AlignTopLeft (cols b + n) b {- | Move a box right by putting it in a larger box with extra columns, aligned right. See the disclaimer for 'moveLeft'. + +>>> error $ render $ moveRight 4 "123" + 123 -} moveRight :: Int -> Box -> Box -moveRight n b = alignHoriz AlignLast (cols b + n) b +moveRight n b = alignHoriz AlignBottomRight (cols b + n) b -------------------------------------------------------------------------------- -- Implementation ------------------------------------------------------------ @@ -307,36 +368,47 @@ moveRight n b = alignHoriz AlignLast (cols b + n) b render :: Box -> String render = unlines . renderBox --- XXX make QC properties for takeP +-- XXX make QC properties for takeExactly -{- | \"Padded take\": @takeP a n xs@ is the same as @take n xs@, if @n +{- | \"Padded take\": @takeExactly a n xs@ is the same as @take n xs@, if @n <= length xs@; otherwise it is @xs@ followed by enough copies of @a@ to make the length equal to @n@. -} -takeP :: a -> Int -> [a] -> [a] -takeP _ n _ | n <= 0 = [] -takeP b n [] = replicate n b -takeP b n (x : xs) = x : takeP b (n -1) xs +takeExactly :: a -> Int -> [a] -> [a] +takeExactly _ n _ | n <= 0 = [] +takeExactly pad n [] = replicate n pad +takeExactly pad n (x : xs) = x : takeExactly pad (n - 1) xs -{- | @takePA @ is like 'takeP', but with alignment. That is, we +{- | @takeExactlyAligned @ is like 'takeExactly', but with alignment. That is, we imagine a copy of @xs@ extended infinitely on both sides with copies of @a@, and a window of size @n@ placed so that @xs@ has - the specified alignment within the window; @takePA algn a n xs@ + the specified alignment within the window; @takeExactlyAligned algn a n xs@ returns the contents of this window. +>>> takeExactlyAligned AlignTopLeft ' ' 10 "12345" +"12345 " + +>>> takeExactlyAligned AlignBottomRight ' ' 10 "12345" +" 12345" + +>>> takeExactlyAligned AlignTopLeftCenter ' ' 10 "12345" +" 12345 " + +>>> takeExactlyAligned AlignBottomRightCenter ' ' 10 "12345" +" 12345 " -} -takePA :: Alignment -> a -> Int -> [a] -> [a] -takePA c b n = glue . (takeP b (numRev c n) *** takeP b (numFwd c n)) . split +takeExactlyAligned :: Alignment -> a -> Int -> [a] -> [a] +takeExactlyAligned ali pad len l = + reverse (takeExactly pad (leftLen ali len) (reverse leftList)) + ++ takeExactly pad (rightLen ali len) rightList where - split t = first reverse . splitAt (numRev c (length t)) $ t - glue = uncurry (++) . first reverse - numFwd AlignTopLeft n = n - numFwd AlignLast _ = 0 - numFwd AlignCenter1 n = n `div` 2 - numFwd AlignCenter2 n = (n + 1) `div` 2 - numRev AlignTopLeft _ = 0 - numRev AlignLast n = n - numRev AlignCenter1 n = (n + 1) `div` 2 - numRev AlignCenter2 n = n `div` 2 + (leftList, rightList) = splitAt (leftLen ali (length l)) l + + rightLen AlignTopLeft n = n + rightLen AlignTopLeftCenter n = n `div` 2 + rightLen AlignBottomRight _ = 0 + rightLen AlignBottomRightCenter n = (n + 1) `div` 2 + + leftLen a n = n - rightLen a n -- | Generate a string of spaces. blanks :: Int -> String @@ -347,41 +419,34 @@ renderBox :: Box -> [String] renderBox (Box r c Blank) = resizeBox r c [""] renderBox (Box r c (Text t)) = resizeBox r c [t] renderBox (Box r c (Row bs)) = - resizeBox r c - . merge - . map (renderBoxWithRows r) - $ bs + resizeBox r c $ merge $ (\b -> renderBox b{rows=r}) <$> bs where merge = foldr (zipWith (++)) (repeat []) renderBox (Box r c (Col bs)) = - resizeBox r c - . concatMap (renderBoxWithCols c) - $ bs + resizeBox r c $ concatMap (\b -> renderBox b{cols=c}) bs renderBox (Box r c (SubBox ha va b)) = - resizeBoxAligned r c ha va - . renderBox - $ b - --- | Render a box as a list of lines, using a given number of rows. -renderBoxWithRows :: Int -> Box -> [String] -renderBoxWithRows r b = renderBox (b{rows = r}) + takeExactlyAligned va (blanks c) r $ + takeExactlyAligned ha ' ' c <$> renderBox b --- | Render a box as a list of lines, using a given number of columns. -renderBoxWithCols :: Int -> Box -> [String] -renderBoxWithCols c b = renderBox (b{cols = c}) - --- | Resize a rendered list of lines. +{- | Resize a rendered list of lines. +>>> resizeBox 5 4 ["1 2 3 4 5 6 7 8 9", "10 11 12 13 14 15 16 17 18 19"] +["1 2 ","10 1"," "," "," "] +-} resizeBox :: Int -> Int -> [String] -> [String] -resizeBox r c = takeP (blanks c) r . map (takeP ' ' c) - --- | Resize a rendered list of lines, using given alignments. -resizeBoxAligned :: Int -> Int -> Alignment -> Alignment -> [String] -> [String] -resizeBoxAligned r c ha va = takePA va (blanks c) r . map (takePA ha ' ' c) +resizeBox rowLen colLen ls = + takeExactly (blanks colLen) rowLen $ + takeExactly ' ' colLen <$> ls -- | A convenience function for rendering a box to stdout. printBox :: Box -> IO () printBox = putStr . render +{- >>> error $ render $ ("123" // "4") <+> ("toto" <+> "foo" // "titi") <+> "bar" +123 toto foo bar +4 titi + +-} + {- -- | Align boxes along their tops. top :: Alignment @@ -389,7 +454,7 @@ top = AlignFirst -- | Align boxes along their bottoms. bottom :: Alignment -bottom = AlignLast +bottom = AlignBottomRight -- | Align boxes to the left. left :: Alignment @@ -397,17 +462,17 @@ left = AlignFirst -- | Align boxes to the right. right :: Alignment -right = AlignLast +right = AlignBottomRight {- | Align boxes centered, but biased to the left/top in case of unequal parities. -} center1 :: Alignment -center1 = AlignCenter1 +center1 = AlignTopLeftCenter {- | Align boxes centered, but biased to the right/bottom in case of unequal parities. -} center2 :: Alignment -center2 = AlignCenter2 +center2 = AlignBottomRightCenter -} diff --git a/src/Literate/Table.hs b/src/Literate/Table.hs index 93c9c93..13834c0 100644 --- a/src/Literate/Table.hs +++ b/src/Literate/Table.hs @@ -37,14 +37,13 @@ import Data.Bool (Bool) import Data.Data import Data.Foldable (foldMap) import Data.Function (($), (.)) -import Data.Functor (fmap) +import Data.Functor (Functor, fmap, (<$>)) import Data.Int (Int) import Data.List ((++)) -import Data.List qualified as L import Data.List qualified as List import Data.Map qualified as Map import Data.Maybe -import Data.String (String) +import Data.String (IsString (..), String) import Data.Tree import Data.Typeable import GHC.Err (undefined) @@ -52,6 +51,7 @@ import GHC.Float (Float) import GHC.Generics as G import GHC.Num (Integer, (+), (-)) import GHC.Show +import Literate.Box (Alignment (AlignTopLeft)) import Literate.Box qualified as B import System.IO (IO) import Text.Printf @@ -72,8 +72,9 @@ instance (GRecordMeta a, Selector s) => GRecordMeta (M1 S s a) where toTree a = [Node (selName a) $ toTree (unM1 a)] instance (GRecordMeta a, Constructor c) => GRecordMeta (M1 C c a) where -- we don't want to build node for constructor - --toTree a = [Node (conName a) $ toTree (unM1 a)] - toTree a = toTree (unM1 a) + toTree a = [Node (conName a) $ toTree (unM1 a)] + +--toTree a = toTree (unM1 a) instance (GRecordMeta a) => GRecordMeta (M1 D c a) where toTree (M1 x) = toTree x instance (CellValueFormatter a, Data a, RecordMeta a) => GRecordMeta (K1 i a) where @@ -147,20 +148,20 @@ instance CellValueFormatter Integer where instance CellValueFormatter Int where ppFormatter x = printf "%d" x instance CellValueFormatter Float where - ppFormatter x = printf "%14.7g" x + ppFormatter x = printf "%g" x instance CellValueFormatter String where ppFormatter x = printf "%s" x instance CellValueFormatter Double where - ppFormatter x = printf "%14.7g" x + ppFormatter x = printf "%g" x instance CellValueFormatter Bool instance (Show a, CellValueFormatter a) => CellValueFormatter (Maybe a) gen_renderTableWithFlds :: [DisplayFld t] -> [t] -> B.Box gen_renderTableWithFlds flds recs = results - where - col_wise_values = fmap (\(DFld f) -> fmap (ppFormatter . f) recs) flds - vertical_boxes = fmap (B.vsep 0 B.AlignTopLeft) $ fmap (fmap B.text) col_wise_values - results = B.hsep 5 B.AlignTopLeft vertical_boxes + where + col_wise_values = fmap (\(DFld f) -> fmap (ppFormatter . f) recs) flds + vertical_boxes = fmap (B.vsep 0 B.AlignTopLeft) $ fmap (fmap fromString) col_wise_values + results = B.hsep 5 B.AlignTopLeft vertical_boxes class Boxable b where printTable :: (G.Generic a, GRecordMeta (Rep a)) => b a -> IO () @@ -198,45 +199,46 @@ instance (CellValueFormatter k) => Boxable (Map.Map k) where printTableWithFlds flds recs = B.printBox $ renderTableWithFlds flds recs renderTableWithFlds flds recs = results - where - data_cols = renderTableWithFlds flds $ Map.elems recs - index_cols = B.vsep 0 B.AlignTopLeft $ fmap (B.text . ppFormatter) $ Map.keys recs - vertical_cols = B.hsep 5 B.AlignTopLeft [index_cols, data_cols] - results = vertical_cols + where + data_cols = renderTableWithFlds flds $ Map.elems recs + index_cols = B.vsep 0 B.AlignTopLeft $ fmap (fromString . ppFormatter) $ Map.keys recs + vertical_cols = B.hsep 5 B.AlignTopLeft [index_cols, data_cols] + results = vertical_cols --- Pretty Print the reords as a table. Handles both records inside +-- Pretty Print the records as a table. Handles both records inside -- Lists and Vectors ppRecords :: (GRecordMeta (Rep a), G.Generic a) => [a] -> B.Box -ppRecords recs = result - where - result = B.hsep 5 B.AlignTopLeft $ createHeaderDataBoxes recs +ppRecords recs = B.punctuateH AlignTopLeft "|" $ createHeaderDataBoxes recs -- Pretty Print the records as a table. Handles records contained in a Map. -- Functions also prints the keys as the index of the table. -ppRecordsWithIndex :: (CellValueFormatter k, GRecordMeta (Rep a), G.Generic a) => (Map.Map k a) -> B.Box -ppRecordsWithIndex recs = result - where - data_boxes = createHeaderDataBoxes $ Map.elems recs - index_box = createIndexBoxes recs - result = B.hsep 5 B.AlignTopLeft $ index_box : data_boxes +ppRecordsWithIndex :: (CellValueFormatter k, GRecordMeta (Rep a), G.Generic a) => Map.Map k a -> B.Box +ppRecordsWithIndex recs = B.punctuateH AlignTopLeft "|" $ index_box : data_boxes + where + data_boxes = createHeaderDataBoxes $ Map.elems recs + index_box = createIndexBoxes recs -- What follows are helper functions to build the B.Box structure to print as table. -- Internal helper functions for building the Tree. -- Build the list of paths from the root to every leaf. +-- >>> constructPath $ Node "" $ recsToTrees ([R00{r00Int = 42, r00String = "foo"}]::[R00])kk +-- [["","root","R00","r00Int","42"],["","root","R00","r00String","foo"]] constructPath :: Tree a -> [[a]] constructPath (Node r []) = [[r]] -constructPath (Node r f) = [r : x | x <- (L.concatMap constructPath f)] +constructPath (Node r f) = [r : x | x <- List.concatMap constructPath f] -- Fill paths with a "-" so that all paths have the -- same length. -fillPath paths = stripped_paths - where - depth = L.maximum $ L.map L.length paths - diff = L.map (\p -> depth - (L.length p)) paths - new_paths = L.map (\(p, d) -> p ++ L.replicate d "-") $ L.zip paths diff - stripped_paths = [xs | x : xs <- new_paths] +-- >>> fillPath ([["1", "2", "3", "4"], ["5"]]::[[String]]) +-- [["2","3","4"],["-","-","-"]] +fillPath :: IsString a => [[a]] -> [[a]] +fillPath paths = [xs | x : xs <- new_paths] + where + depth = List.maximum $ List.length <$> paths + diff = (\p -> depth - List.length p) <$> paths + new_paths = (\(p, d) -> p ++ List.replicate d "-") <$> List.zip paths diff -- Count the number of fields in the passed structure. -- The no of leaves is the sum of all fields across all nested @@ -245,73 +247,115 @@ countLeaves :: Tree a -> Tree (Int, a) countLeaves (Node r f) = case f of [] -> Node (1, r) [] x -> countLeaves' x - where - countLeaves' x = - let count_leaves = fmap countLeaves x - level_count = List.foldr (\(Node (c, a) _) b -> c + b) 0 count_leaves - in Node (level_count, r) count_leaves + where + countLeaves' x = + let count_leaves = fmap countLeaves x + level_count = List.foldr (\(Node (c, a) _) b -> c + b) 0 count_leaves + in Node (level_count, r) count_leaves --- Trims a the tree of records and return just the +-- Trims the tree of records and return just the -- leaves of the record +-- >>> error $ drawTree $ trimTree $ Node "" $ recsToTrees ([R00{r00Int = 42, r00String = "foo"}]::[R00]) + +{- | + `- root + | + `- R00 + | + +- r00Int + | + `- r00String +-} +trimTree :: Tree t -> Tree t trimTree (Node r f) = trimLeaves r f -- Helper function called by trimTree. -trimLeaves r f = Node r (trimLeaves' f) - where - trimLeaves' f = - let result = fmap trimLeaves'' f - where - trimLeaves'' (Node r' f') = - let result' = case f' of +trimLeaves :: t -> [Tree t] -> Tree t +trimLeaves r f = Node r (go f) + where + go f = + let result = goo <$> f + where + goo (Node r' f') = + case f' of [] -> Nothing _ -> Just $ trimLeaves r' f' - in result' - in catMaybes result + in catMaybes result --- Get all the leaves from the record. Returns all leaves --- across the record structure. +-- Get all the leaves from the record. +-- Returns all leaves across the record structure. getLeaves :: (CellValueFormatter a) => Tree a -> [String] getLeaves (Node r f) = case f of - [] -> [(ppFormatter r)] + [] -> [ppFormatter r] _ -> foldMap getLeaves f -recsToTrees recs = fmap (\a -> Node "root" $ (toTree . G.from $ a)) $ recs - -getHeaderDepth rec_trees = header_depth - where - header_depth = L.length . L.head . fillPath . constructPath . trimTree . L.head $ rec_trees - -createBoxedHeaders :: [[String]] -> [B.Box] -createBoxedHeaders paths = boxes - where - boxes = L.map wrapWithBox paths - wrapWithBox p = B.vsep 0 B.AlignTopLeft $ L.map B.text p - ---createHeaderCols :: [Tree String] -> [B.Box] -createHeaderCols rec_trees = header_boxes - where - header_boxes = createBoxedHeaders . fillPath . constructPath . trimTree . L.head $ rec_trees +{- | >>> y recsToTrees ([R00{r00Int = 42, r00String = "foo"}]::[R00]) + root + NOW | + NOW `- R00 + NOW | + NOW +- r00Int + NOW | | + NOW | `- 42 + NOW | + NOW `- r00String + NOW | + NOW `- foo + | + +- r00Int + | | + | `- 42 + | + `- r00String + | + `- foo +-} +recsToTrees :: (Functor f, GRecordMeta (Rep a), Generic a) => f a -> f (Tree String) +recsToTrees = fmap (\a -> Node "root" $ toTree $ G.from a) ---createDataBoxes :: [Tree a] -> [B.Box] -createDataBoxes rec_trees = vertical_boxes - where - horizontal_boxes = fmap (fmap B.text) $ fmap getLeaves rec_trees - vertical_boxes = fmap (B.vsep 0 B.AlignTopLeft) $ L.transpose horizontal_boxes +getHeaderDepth :: IsString a => [Tree a] -> Int +getHeaderDepth = List.length . List.head . fillPath . constructPath . trimTree . List.head --createIndexBoxes :: Map.Map a a -> B.Box +createIndexBoxes :: (GRecordMeta (Rep a), Generic a, CellValueFormatter k) => Map.Map k a -> B.Box createIndexBoxes recs = index_box - where - rec_trees = recsToTrees $ Map.elems recs - header_depth = getHeaderDepth rec_trees - index_col = (L.replicate header_depth "-") ++ (L.map ppFormatter $ Map.keys recs) - index_box = B.vsep 0 B.AlignTopLeft $ L.map B.text index_col + where + rec_trees = recsToTrees $ Map.elems recs + header_depth = getHeaderDepth rec_trees + index_col = List.replicate header_depth "-" ++ List.map ppFormatter (Map.keys recs) + index_box = B.vsep 0 B.AlignTopLeft $ List.map fromString index_col +createHeaderDataBoxes :: (GRecordMeta (Rep a), Generic a) => [a] -> [B.Box] createHeaderDataBoxes recs = vertical_boxes - where - rec_trees = recsToTrees recs - header_boxes = createHeaderCols rec_trees - data_boxes = createDataBoxes rec_trees - vertical_boxes = fmap (\(a, b) -> B.vsep 0 B.AlignTopLeft $ [a, b]) $ L.zip header_boxes data_boxes + where + rec_trees = recsToTrees recs + header_boxes = createHeaderCols rec_trees + data_boxes = createDataBoxes rec_trees + vertical_boxes = (\(a, b) -> B.vsep 0 B.AlignTopLeft [a, b]) <$> List.zip header_boxes data_boxes + +-- >>> error $ B.render $ B.hcat AlignTopLeft $ createHeaderCols $ recsToTrees ([R00{r00Int = 42, r00String = "foo"}]::[R00]) +-- R00 R00 +-- r00Intr00String +createHeaderCols :: [Tree String] -> [B.Box] +createHeaderCols rec_trees = + createBoxedHeaders $ + fillPath $ + constructPath $ + trimTree $ + List.head rec_trees + +createBoxedHeaders :: [[String]] -> [B.Box] +createBoxedHeaders paths = B.vsep 0 B.AlignTopLeft . (fromString <$>) <$> paths + +-- >>> error $ B.render $ B.hcat AlignTopLeft $ createDataBoxes $ recsToTrees ([R00{r00Int = 42, r00String = "foo"}]::[R00]) +-- 42foo +-- >>> error $ B.render $ B.hcat AlignTopLeft $ createDataBoxes $ recsToTrees ([getR01]::[R01]) +-- Jack-Jack100.101021Just 10.101 +createDataBoxes :: CellValueFormatter a => [Tree a] -> [B.Box] +createDataBoxes rec_trees = vertical_boxes + where + horizontal_boxes = (fromString <$>) <$> (getLeaves <$> rec_trees) + vertical_boxes = B.vsep 0 B.AlignTopLeft <$> List.transpose horizontal_boxes -- testing @@ -343,7 +387,7 @@ data DisplayFld a = forall s. CellValueFormatter s => DFld (a -> s) -- printTableWithFlds3 flds recs = results -- where -- data_cols = renderTableWithFlds flds $ Map.elems recs --- index_cols = B.vsep 0 B.AlignTopLeft $ fmap (B.text . ppFormatter) $ Map.keys recs +-- index_cols = B.vsep 0 B.AlignTopLeft $ fmap (fromString . ppFormatter) $ Map.keys recs -- vertical_cols = B.hsep 5 B.AlignTopLeft [index_cols, data_cols] -- results = B.render vertical_cols @@ -354,7 +398,10 @@ data R00 } | R00_ { r00_Int :: Int - + , r00_String :: String + } + deriving (Show, Generic, Data) +instance CellValueFormatter R00 -- R0 has to derive from Data, since -- it will be nested @@ -402,12 +449,15 @@ recordsList = List.replicate 2 $ getR03 -- >>> B.cols $ renderTable recordsList -- 91 --- >>> error $ B.render $ renderTable recordsList --- r3_id r3_r02 r3_r02 r3_r02 r3_r02 r3_r02 r3_r02 --- - r2_r00 r2_r00 r2_r01 r2_r01 r2_r01 r2_r01 --- - r00Int r00String test_string test_integer test_float test_DOUBLE --- 200 100 foo Jack-Jack 10 0.1010210 Just 10.101 --- 200 100 foo Jack-Jack 10 0.1010210 Just 10.101 +-- >>> error $ B.render $ ppRecords recordsList +-- R03 |R03 |R03 |R03 |R03 |R03 +-- r3_id r3_r02 r3_r02 r3_r02 r3_r02 r3_r02 +-- - R02 R02 R02 R02 R02 +-- - r2_r00 r2_r01 r2_r01 r2_r01 r2_r01 +-- - - R01 R01 R01 R01 +-- - - test_string test_integer test_float test_DOUBLE +-- 200 R00_ {r00_Int = 100, r00_String = "foo"} Jack-Jack 10 0.101021 Just 10.101 +-- 200 R00_ {r00_Int = 100, r00_String = "foo"} Jack-Jack 10 0.101021 Just 10.101 recordsMap = Map.fromList @@ -422,10 +472,13 @@ recordsMap = -- >>> B.cols $ renderTable recordsMap -- 100 --- >>> error $ B.render $ renderTable recordsMap --- - r3_id r3_r02 r3_r02 r3_r02 r3_r02 r3_r02 r3_r02 --- - - r2_r00 r2_r00 r2_r01 r2_r01 r2_r01 r2_r01 --- - - r00Int r00String test_string test_integer test_float test_DOUBLE --- key1 200 100 foo Jack-Jack 10 0.1010210 Just 10.101 --- key2 200 100 foo Jack-Jack 10 0.1010210 Just 10.101 --- key3 32 100 foo Jack-Jack 10 0.1010210 Just 10.101 +-- >>> error $ B.render $ ppRecordsWithIndex recordsMap +-- - R03 R03 R03 R03 R03 R03 +-- - r3_id r3_r02 r3_r02 r3_r02 r3_r02 r3_r02 +-- - - R02 R02 R02 R02 R02 +-- - - r2_r00 r2_r01 r2_r01 r2_r01 r2_r01 +-- - - - R01 R01 R01 R01 +-- - - - test_string test_integer test_float test_DOUBLE +-- key1 200 R00_ {r00_Int = 100, r00_String = "foo"} Jack-Jack 10 0.101021 Just 10.101 +-- key2 200 R00_ {r00_Int = 100, r00_String = "foo"} Jack-Jack 10 0.101021 Just 10.101 +-- key3 32 R00_ {r00_Int = 100, r00_String = "foo"} Jack-Jack 10 0.101021 Just 10.101