Improved prettyprinting, allow manual ordering in Huddle

Generalized tabular prettyprinting
Added prettyprinter tests
collectFrom now takes HuddleItems

Author: Soupstraw

.github/workflows/ci.yml

@@ -17,7 +17,7 @@ jobs:
     strategy:
       fail-fast: false
       matrix:
-        ghc: ["8.10.7", "9.2.8", "9.6.4", "9.8.1"]
+        ghc: ["8.10.7", "9.2.8", "9.6.4", "9.8.1", "9.10.1"]
         os: [ubuntu-latest]
     steps:
     - uses: actions/checkout@v3

src/Codec/CBOR/Cuddle/CDDL.hs

@@ -53,6 +53,11 @@ import Optics.Core ((%), (.~))
 import Optics.Getter (view)
 import Optics.Lens (lens)
 
+-- | The CDDL constructor takes three arguments:
+--     1. Top level comments that precede the first definition
+--     2. The root definition
+--     3. All the other top level comments and definitions
+--   This ensures that `CDDL` is correct by construction.
 data CDDL = CDDL [Comment] Rule [TopLevel]
   deriving (Eq, Generic, Show, ToExpr)
 

src/Codec/CBOR/Cuddle/CDDL/Resolve.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE LambdaCase #-}
@@ -58,12 +59,14 @@ import Data.Functor.Identity (Identity (..))
 import Data.Generics.Product
 import Data.Generics.Sum
 import Data.Hashable
+#if __GLASGOW_HASKELL__ < 9100
+import Data.List (foldl')
+#endif
 import Data.List.NonEmpty qualified as NE
 import Data.Map.Strict qualified as Map
 import Data.Text qualified as T
 import GHC.Generics (Generic)
 import Optics.Core
-import Data.List (foldl')
 
 --------------------------------------------------------------------------------
 -- 1. Rule extensions
@@ -214,9 +217,6 @@ buildRefCTree rules = CTreeRoot $ fmap toCTreeRule rules
     toCTreeDataItem _ =
       It $ CTree.Postlude PTAny
 
-    toCTreeGroupEntryNC :: GroupEntry -> CTree.Node OrRef
-    toCTreeGroupEntryNC = toCTreeGroupEntry
-
     toCTreeGroupEntry :: GroupEntry -> CTree.Node OrRef
     toCTreeGroupEntry (GroupEntry (Just occi) _ (GEType mmkey t0)) =
       It $
@@ -247,20 +247,20 @@ buildRefCTree rules = CTreeRoot $ fmap toCTreeRule rules
     -- choice options
     toCTreeEnum :: Group -> CTree.Node OrRef
     toCTreeEnum (Group (a NE.:| [])) =
-      It . CTree.Enum . It . CTree.Group $ toCTreeGroupEntryNC <$> gcGroupEntries a
+      It . CTree.Enum . It . CTree.Group $ toCTreeGroupEntry <$> gcGroupEntries a
     toCTreeEnum (Group xs) =
       It . CTree.Choice $
-        It . CTree.Enum . It . CTree.Group . fmap toCTreeGroupEntryNC <$> groupEntries
+        It . CTree.Enum . It . CTree.Group . fmap toCTreeGroupEntry <$> groupEntries
       where
         groupEntries = fmap gcGroupEntries xs
 
     -- Embed a group in another group, again floating out the choice options
     groupToGroup :: Group -> CTree.Node OrRef
     groupToGroup (Group (a NE.:| [])) =
-      It . CTree.Group $ fmap toCTreeGroupEntryNC (gcGroupEntries a)
+      It . CTree.Group $ fmap toCTreeGroupEntry (gcGroupEntries a)
     groupToGroup (Group xs) =
       It . CTree.Choice $
-        fmap (It . CTree.Group . fmap toCTreeGroupEntryNC) (gcGroupEntries <$> xs)
+        fmap (It . CTree.Group . fmap toCTreeGroupEntry) (gcGroupEntries <$> xs)
 
     toKVPair :: Maybe MemberKey -> Type0 -> CTree.Node OrRef
     toKVPair Nothing t0 = toCTreeT0 t0
@@ -275,20 +275,20 @@ buildRefCTree rules = CTreeRoot $ fmap toCTreeRule rules
 
     -- Interpret a group as a map. Note that we float out the choice options
     toCTreeMap :: Group -> CTree.Node OrRef
-    toCTreeMap (Group (a NE.:| [])) = It . CTree.Map $ fmap toCTreeGroupEntryNC (gcGroupEntries a)
+    toCTreeMap (Group (a NE.:| [])) = It . CTree.Map $ fmap toCTreeGroupEntry (gcGroupEntries a)
     toCTreeMap (Group xs) =
       It
         . CTree.Choice
-        $ fmap (It . CTree.Map . fmap toCTreeGroupEntryNC) (gcGroupEntries <$> xs)
+        $ fmap (It . CTree.Map . fmap toCTreeGroupEntry) (gcGroupEntries <$> xs)
 
     -- Interpret a group as an array. Note that we float out the choice
     -- options
     toCTreeArray :: Group -> CTree.Node OrRef
     toCTreeArray (Group (a NE.:| [])) =
-      It . CTree.Array $ fmap toCTreeGroupEntryNC (gcGroupEntries a)
+      It . CTree.Array $ fmap toCTreeGroupEntry (gcGroupEntries a)
     toCTreeArray (Group xs) =
       It . CTree.Choice $
-        fmap (It . CTree.Array . fmap toCTreeGroupEntryNC) (gcGroupEntries <$> xs)
+        fmap (It . CTree.Array . fmap toCTreeGroupEntry) (gcGroupEntries <$> xs)
 
     toCTreeMemberKey :: MemberKey -> CTree.Node OrRef
     toCTreeMemberKey (MKValue v) = It $ CTree.Literal v

src/Codec/CBOR/Cuddle/Comments.hs

@@ -121,14 +121,24 @@ instance CollectComments Comment where
 hasComment :: HasComment a => a -> Bool
 hasComment = (/= mempty) . view commentL
 
+-- | This operator is used to attach comments to terms. It will not overwrite
+-- any comments that are already present, but will add the new comments on a
+-- new line
+-- ```
+-- arr [0, 1] //- "This is an array with two values"
+-- ```
 (//-) :: HasComment a => a -> Comment -> a
 x //- cmt = x & commentL %~ (<> cmt)
 
 infixr 0 //-
 
+-- | This operator will parse the values from left to right and then append the
+-- parsed comment on the right to the parsed value on the left.
 (<*!) :: (HasComment a, Applicative m) => m a -> m Comment -> m a
-(<*!) c x = (//-) <$> c <*> x
+(<*!) x c = (//-) <$> x <*> c
 
+-- | This operator will parse the values from left to right and then append the
+-- parsed comment on the left to the parsed value on the right.
 (!*>) :: (HasComment a, Applicative m) => m Comment -> m a -> m a
 (!*>) c x = flip (//-) <$> c <*> x
 
@@ -154,6 +164,11 @@ instance CollectComments a => CollectComments (WithComment a) where
 withComment :: a -> WithComment a
 withComment = WithComment mempty
 
+-- | This operator maps a function over a functor containing a `WithComment` and
+-- applies the comment within to the output of the applied function.
+-- ```
+-- (\x -> LInt x "a") !$> WithComment "b" (1 :: Integer) == Literal (LInt 1) "a\nb"
+-- ```
 (!$>) :: (HasComment b, Functor f) => (a -> b) -> f (WithComment a) -> f b
 f !$> wc = fmap (\(WithComment c x) -> f x //- c) wc
 

src/Codec/CBOR/Cuddle/Huddle.hs

@@ -20,7 +20,7 @@ module Codec.CBOR.Cuddle.Huddle (
   -- * Core Types
   Huddle,
   HuddleItem (..),
-  huddleJoin,
+  huddleAugment,
   Rule,
   Named,
   IsType0 (..),
@@ -144,8 +144,11 @@ data Huddle = Huddle
   }
   deriving (Generic, Show)
 
-huddleJoin :: Huddle -> Huddle -> Huddle
-huddleJoin (Huddle rootsL itemsL) (Huddle rootsR itemsR) =
+-- | Joins two `Huddle` values with a left-bias. This means that this function
+-- is not symmetric and that any rules that are present in both prefer the
+-- definition from the `Huddle` value on the left.
+huddleAugment :: Huddle -> Huddle -> Huddle
+huddleAugment (Huddle rootsL itemsL) (Huddle rootsR itemsR) =
   Huddle (L.nubBy ((==) `on` name) $ rootsL <> rootsR) (itemsL |<> itemsR)
 
 -- | This semigroup instance:
@@ -1057,7 +1060,7 @@ collectFrom topRs =
 collectFromInit :: [HuddleItem] -> Huddle
 collectFromInit rules =
   Huddle (concatMap hiRule rules) (OMap.fromList $ (\x -> (hiName x, x)) <$> rules)
-    `huddleJoin` collectFrom rules
+    `huddleAugment` collectFrom rules
 
 --------------------------------------------------------------------------------
 -- Conversion to CDDL

src/Codec/CBOR/Cuddle/Pretty/Columnar.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 
+-- | This module provides some utility functions to help with aligning pretty
+-- printed values by column.
 module Codec.CBOR.Cuddle.Pretty.Columnar (
   CellAlign (..),
   Row (..),
@@ -27,33 +29,46 @@ data Cell ann = Cell
   , cellAlign :: CellAlign
   }
 
+-- | Creates a cell by pretty printing the input value and then left-aligning
+-- the resulting `Doc` within the table.
 cellL :: Pretty a => a -> Cell ann
 cellL = (`Cell` LeftAlign) . pretty
 
+-- | Creates a cell by pretty printing the input value and then right-aligning
+-- the resulting `Doc` within the table.
 cellR :: Pretty a => a -> Cell ann
 cellR = (`Cell` RightAlign) . pretty
 
+-- | A cell that takes up a cell but has no content.
 emptyCell :: Cell ann
 emptyCell = Cell mempty LeftAlign
 
+-- | Checks whether the cell contains a `Doc` with a rendered width of zero.
 isEmptyCell :: Cell ann -> Bool
 isEmptyCell (Cell d _) = renderedLen d == 0
 
+-- | A row within the table.
 newtype Row ann = Row {rowCells :: [Cell ann]}
 
+-- | Adds a cell at the beginning of the row.
 prependCell :: Cell ann -> Row ann -> Row ann
 prependCell c (Row cs) = Row $ c : cs
 
+-- | A row with a single left-aligned document
 singletonRow :: Doc ann -> Row ann
 singletonRow x = Row [Cell x LeftAlign]
 
+-- | `Columnar` is a two-dimensional table of `Doc`s. When rendered, the cells
+-- within each row will be aligned with the cells of every other row in the
+-- same column.
 newtype Columnar ann = Columnar {colRows :: [Row ann]}
 
 prettyRow :: [Int] -> [Cell ann] -> Doc ann
 prettyRow = prettyRow'
   where
     prettyRow' [] (Cell c _ : cs) = c <> prettyRow' [] cs
     prettyRow' _ [] = mempty
+    prettyRow' _ [Cell c LeftAlign] = c -- Do not add white space to the last cell
     prettyRow' (0 : ws) (_ : cs) = prettyRow' ws cs -- Skip empty columns
     prettyRow' (w : ws) (Cell c alignment : cs) =
       let
@@ -63,12 +78,23 @@ prettyRow = prettyRow'
        in
         align' w c <> prettyRow' ws cs
 
+-- | Pretty print the `Columnar` as a table.
 prettyColumnar :: forall ann. Columnar ann -> Doc ann
 prettyColumnar (Columnar rows) = vcat $ prettyRow columnWidths . rowCells <$> rows
   where
     columnWidths =
       foldr (zipWith max . fmap (renderedLen . cellDoc) . rowCells) (repeat 0) rows
 
+-- | Pretty prints the `Columnar` so that the rows are separated by by the
+-- separator `Doc` provided as the third argument and then everything is
+-- enclosed within the left and right brackets provided as the first and second
+-- argument accordingly. The brackets will be aligned with the separators in the
+-- first column, e.g.
+-- ```
+-- [ foo
+-- , bar
+-- ]
+-- ```
 columnarListing :: Doc ann -> Doc ann -> Doc ann -> Columnar ann -> Doc ann
 columnarListing lEnc rEnc _ (Columnar []) = lEnc <> rEnc
 columnarListing lEnc rEnc s (Columnar (row : rows)) =
@@ -80,10 +106,22 @@ columnarListing lEnc rEnc s (Columnar (row : rows)) =
     <> line'
     <> rEnc
 
+-- | Pretty prints the `Columnar` so that every line after the first has a
+-- separator prepended to it. This can be useful when you want to align the rows,
+-- but the separator would cause all the other rows after the first to be shifted
+-- right by one. The way you use this is you reduce the indentation on the
+-- following lines by the width of the separator.
+-- ```
+-- foo = x
+--     , y
+--     , z
+-- ```
 columnarSepBy :: Doc ann -> Columnar ann -> Doc ann
 columnarSepBy _ (Columnar []) = mempty
-columnarSepBy s (Columnar (x : xs)) =
-  prettyColumnar (Columnar [x]) <> line' <> prettyColumnar (Columnar $ prependRow <$> xs)
+columnarSepBy s (Columnar rows@(Row x : xs)) =
+  prettyRow columnWidths x <> line' <> prettyColumnar (Columnar $ prependRow <$> xs)
   where
     prependRow (Row (Cell c al : cs)) = Row $ Cell (s <+> c) al : cs
     prependRow (Row []) = Row []
+    columnWidths =
+      foldr (zipWith max . fmap (renderedLen . cellDoc) . rowCells) (repeat 0) rows