"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",
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 {
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
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|
-}
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
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 =
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'.
+{-# LANGUAGE OverloadedStrings #-}
+
{- |
Module : Text.PrettyPrint.Boxes
Copyright : (c) Brent Yorgey 2009
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.
-}
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
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.
-}
{- | @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
{- | @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 -----------------------------------------------------------------
{- | @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
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 ------------------------------------------------------------
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
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
-- | Align boxes along their bottoms.
bottom :: Alignment
-bottom = AlignLast
+bottom = AlignBottomRight
-- | Align boxes to the left.
left :: Alignment
-- | 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
-}
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)
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
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
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 ()
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
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
-- 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
}
| 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
-- >>> 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
-- >>> 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
sourcephile / git / haskell / literate-accounting.git / commitdiff