wip

diff --git a/flake.lock b/flake.lock
index 05a728125a035857a6376d542017684b137e3fd3..4a16d0bbcf810a0224c2b49015fcb4b66f886015 100644 (file)
--- a/flake.lock
+++ b/flake.lock
@@ -2,11 +2,12 @@
   "nodes": {
     "nixpkgs": {
       "locked": {
   "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",
       },
       "original": {
         "id": "nixpkgs",

diff --git a/flake.nix b/flake.nix
index dd6cf08055ee143b2e3f8194c86f1ac0ad9cc2a7..dde9aae65b430a38742c7fe3d0336c4fe267778e 100644 (file)
--- 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 ./. {});
     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 {
     });
   });
   in {

diff --git a/fourmolu.yaml b/fourmolu.yaml
index 95c8107b738f9e322cc164e450cd465398f43174..e7453cd73384fbe43a2e88a4615c9069c2a511af 100644 (file)
--- a/fourmolu.yaml
+++ b/fourmolu.yaml
@@ -1,7 +1,7 @@
 comma-style: leading
 diff-friendly-import-export: true
 haddock-style: multi-line
 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
 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 848d77591c82cdd4bf175a6a78be093e035f4264..ba38287be4bdc2e49e0d5fd0994635680cf2ce82 100644 (file)
--- 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
 
 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 :: [[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|
 
 {- >>> 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
 -}
 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
 
 -- | 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 []
 
 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 =
 
 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
 
 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 []
 
 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'.
 -- * Type 'ChartM'
 
 -- | A 'Monad' to construct a 'Chart'.

diff --git a/src/Literate/Box.hs b/src/Literate/Box.hs
index 5a5e532fad248853fc4e3cec499324581e558516..78bb9e7503672d266519465e68287e2c08a4f9f6 100644 (file)
--- 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
 {- |
  Module      :  Text.PrettyPrint.Boxes
  Copyright   :  (c) Brent Yorgey 2009


@@ -12,34 +14,14 @@
 module Literate.Box where
 
 import Control.Arrow (first, (***))
 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.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)
 
 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.
 -}
 {- | 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)
 
     SubBox Alignment Alignment Box
   deriving (Show)
 

--- | Convenient ability to use bare string literals as boxes.

 instance IsString Box where
 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.
 
 -- | 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.
   | -- | Centered, biased to the bottom/right.

-    AlignCenter2
+    AlignBottomRightCenter

   | -- | Align at the bottom/right.
   | -- | Align at the bottom/right.

-    AlignLast
+    AlignBottomRight

   deriving (Eq, Read, Show)
 
 {- | The null box, which has no content and no size.  It is quite
   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])
 
 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.
 -}
 {- | 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 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
 -}
 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.
 {- | @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
 
 -}
 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 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 =
 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
 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 :: Int -> Para

-emptyPara pw = Para pw (Block [] (Line 0 []))
+emptyPara pw = Para pw (ParaContent [] (Line 0 []))

 
 getLines :: Para -> [String]
 
 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
   | 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 :: [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 . (: [])
 
 
 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 -> 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 :: 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 :: 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  -----------------------------------------------------------------
 
 --------------------------------------------------------------------------------
 --  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@.
 {- | @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
 
 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
    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.
 
 {- | 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'.
 -}
 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 :: Int -> Box -> Box

-moveRight n b = alignHoriz AlignLast (cols b + n) b
+moveRight n b = alignHoriz AlignBottomRight (cols b + n) b

 
 --------------------------------------------------------------------------------
 --  Implementation  ------------------------------------------------------------
 
 --------------------------------------------------------------------------------
 --  Implementation  ------------------------------------------------------------


@@ -307,36 +368,47 @@ moveRight n b = alignHoriz AlignLast (cols b + n) b
 render :: Box -> String
 render = unlines . renderBox
 
 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@.
 -}
    <= 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
    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.
    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
  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
 
 -- | 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)) =
 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)) =
  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)) =
 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 :: 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
 
 
 -- | 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 tops.
 top :: Alignment


@@ -389,7 +454,7 @@ top = AlignFirst
 
 -- | Align boxes along their bottoms.
 bottom :: Alignment
 
 -- | Align boxes along their bottoms.
 bottom :: Alignment

-bottom = AlignLast
+bottom = AlignBottomRight

 
 -- | Align boxes to the left.
 left :: Alignment
 
 -- | Align boxes to the left.
 left :: Alignment


@@ -397,17 +462,17 @@ left = AlignFirst
 
 -- | Align boxes to the right.
 right :: 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
 
 {- | 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
 
 {- | 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 93c9c9320193ffac9e6eba9b81108112f41484a9..13834c0b049704205952aeb8d5635de16fb0dead 100644 (file)
--- 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.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.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.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 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 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
 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 (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 (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
 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
 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
 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 ()
 
 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
   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
 -- 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.
 
 -- 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.
 
 -- 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 :: 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.
 
 -- 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
 
 -- 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
 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
 -- 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.
 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'
                   [] -> 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
 getLeaves :: (CellValueFormatter a) => Tree a -> [String]
 getLeaves (Node r f) = case f of

-  [] -> [(ppFormatter r)]
+  [] -> [ppFormatter r]

   _ -> foldMap getLeaves f
 
   _ -> 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 :: Map.Map a a -> B.Box

+createIndexBoxes :: (GRecordMeta (Rep a), Generic a, CellValueFormatter k) => Map.Map k a -> B.Box

 createIndexBoxes recs = index_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
 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
 
 
 -- 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
 -- 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
 
 --   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_
       { r00_Int :: Int

-
+      , r00_String :: String
+      }
+  deriving (Show, Generic, Data)
+instance CellValueFormatter R00

 
 -- R0 has to derive from Data, since
 -- it will be nested
 
 -- 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
 
 -- >>> 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
 
 recordsMap =
   Map.fromList


@@ -422,10 +472,13 @@ recordsMap =
 -- >>> B.cols $ renderTable recordsMap
 -- 100
 
 -- >>> 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