Improved prettyprinting, allow manual ordering in Huddle

Generalized tabular prettyprinting
Added prettyprinter tests
collectFrom now takes HuddleItems

Author: Soupstraw

.github/workflows/ci.yml

@@ -72,7 +72,7 @@ jobs:
 
     - name: Install fourmolu
       run: |
-        FOURMOLU_VERSION="0.16.2.0"
+        FOURMOLU_VERSION="0.14.0.0"
         mkdir -p "$HOME/.local/bin"
         curl -sL "https://github.com/fourmolu/fourmolu/releases/download/v${FOURMOLU_VERSION}/fourmolu-${FOURMOLU_VERSION}-linux-x86_64" -o "$HOME/.local/bin/fourmolu"
         chmod a+x "$HOME/.local/bin/fourmolu"

bin/Main.hs

@@ -167,7 +167,7 @@ run (Opts cmd cddlFile) = do
               Left err -> putStrLnErr (show err) >> exitFailure
               Right mt -> do
                 stdGen <- getStdGen
-                let term = generateCBORTerm mt (Name $ itemName gOpts) stdGen
+                let term = generateCBORTerm mt (Name (itemName gOpts) mempty) stdGen
                  in case outputFormat gOpts of
                       AsTerm -> print term
                       AsFlatTerm -> print $ toFlatTerm (encodeTerm term)

cuddle.cabal

@@ -50,19 +50,23 @@ library
     Codec.CBOR.Cuddle.CDDL.Postlude
     Codec.CBOR.Cuddle.CDDL.Prelude
     Codec.CBOR.Cuddle.CDDL.Resolve
+    Codec.CBOR.Cuddle.Comments
     Codec.CBOR.Cuddle.Huddle
     Codec.CBOR.Cuddle.Huddle.HuddleM
     Codec.CBOR.Cuddle.Huddle.Optics
     Codec.CBOR.Cuddle.Parser
     Codec.CBOR.Cuddle.Parser.Lexer
     Codec.CBOR.Cuddle.Pretty
+    Codec.CBOR.Cuddle.Pretty.Columnar
+    Codec.CBOR.Cuddle.Pretty.Utils
 
   other-modules:
 
   -- other-extensions:
   build-depends:
     , base                >=4.14.0.0
     , base16-bytestring
+    , boxes
     , bytestring
     , capability
     , cborg
@@ -128,6 +132,7 @@ test-suite cuddle-test
     Test.Codec.CBOR.Cuddle.CDDL.Examples
     Test.Codec.CBOR.Cuddle.CDDL.Gen
     Test.Codec.CBOR.Cuddle.CDDL.Parser
+    Test.Codec.CBOR.Cuddle.CDDL.Pretty
     Test.Codec.CBOR.Cuddle.Huddle
 
   -- other-extensions:
@@ -136,11 +141,15 @@ test-suite cuddle-test
   main-is:          Main.hs
   build-depends:
     , base              >=4.14.0.0
+    , bytestring
     , cuddle
+    , data-default-class
     , hspec
     , hspec-megaparsec
+    , HUnit
     , megaparsec
     , prettyprinter
+    , string-qq
     , QuickCheck
     , text
     , tree-diff

example/Conway.hs

@@ -20,7 +20,7 @@ import GHC.Show (Show (show))
 default (Integer, Double)
 
 conway :: Huddle
-conway = collectFrom [block]
+conway = collectFrom [HIRule block]
 
 block :: Rule
 block =

example/Main.hs

@@ -61,7 +61,7 @@ main = do
           case buildMonoCTree =<< buildResolvedCTree (buildRefCTree (asMap res)) of
             Left nre -> error $ show nre
             Right mt ->
-              let term = generateCBORTerm mt (Name $ T.pack name) stdGen
+              let term = generateCBORTerm mt (Name (T.pack name) mempty) stdGen
                in print term
     [] -> do
       let cw = toCDDL conway

example/Monad.hs

@@ -7,6 +7,7 @@
 
 module Monad where
 
+import Codec.CBOR.Cuddle.Comments ((//-))
 import Codec.CBOR.Cuddle.Huddle qualified as Huddle
 import Codec.CBOR.Cuddle.Huddle.HuddleM
 import Data.Word (Word64)
@@ -43,9 +44,9 @@ spec2 =
           _transaction <-
             "transaction"
               =:= mp
-                [ comment "Transaction inputs" $ idx 0 ==> set txIn
-                , comment "Transaction outputs" $ idx 1 ==> set txOut
-                , comment "Metadata" $ idx 2 ==> metadata
+                [ idx 0 ==> set txIn //- "Transaction inputs"
+                , idx 1 ==> set txOut //- "Transaction outputs"
+                , idx 2 ==> metadata //- "Metadata"
                 ]
           metadata <- "metadata" =:= VBytes
           _value <- "value" =:= mp ["token" ==> VText, "quantity" ==> VUInt]

flake.lock

@@ -1,3 +1,3 @@
 {
-  organist = import "/nix/store/2r3m9zdvydnrlmh3mvk15m3xddxschgy-source/lib/organist.ncl",
+  organist = import "/nix/store/7zrf2b1ysrgrx7613qlmbz71cfyxgyfb-source/lib/organist.ncl",
 }

nickel.lock.ncl

@@ -17,13 +17,14 @@ let shellFor = fun ghcver =>
   } in
 
 {
-  shells = organist.shells.Bash,
+  config = {
+    shells = organist.shells.Bash,
 
-  shells.build = {
-    packages = {},
-  },
-
-  shells.dev = shellFor "ghc964",
+    shells.build = {
+      packages = {},
+    },
 
+    shells.dev = shellFor "ghc964",
+  }
 }
   | organist.OrganistExpression

project.ncl

@@ -21,6 +21,7 @@ import Codec.CBOR.Cuddle.CDDL (
   Name (..),
   OccurrenceIndicator (..),
   Value (..),
+  ValueVariant (..),
  )
 import Codec.CBOR.Cuddle.CDDL.CTree (CTree, CTreeRoot' (..))
 import Codec.CBOR.Cuddle.CDDL.CTree qualified as CTree
@@ -38,7 +39,6 @@ import Data.ByteString (ByteString)
 import Data.ByteString.Base16 qualified as Base16
 import Data.Functor ((<&>))
 import Data.Functor.Identity (Identity (runIdentity))
-import Data.List (foldl')
 import Data.List.NonEmpty qualified as NE
 import Data.Map.Strict qualified as Map
 import Data.Maybe (fromMaybe)
@@ -155,7 +155,7 @@ genDepthBiasedRM bounds = do
 genDepthBiasedBool :: forall g. RandomGen g => M g Bool
 genDepthBiasedBool = do
   d <- get @"depth"
-  foldl' (&&) True <$> replicateM d genRandomM
+  and <$> replicateM d genRandomM
 
 genRandomM :: forall g a. (Random a, RandomGen g) => M g a
 genRandomM = asksM @"fakeSeed" randomM
@@ -304,15 +304,15 @@ genForCTree (CTree.Control op target controller) = do
   tt <- resolveIfRef target
   ct <- resolveIfRef controller
   case (op, ct) of
-    (CtlOp.Le, CTree.Literal (VUInt n)) -> case tt of
+    (CtlOp.Le, CTree.Literal (Value (VUInt n) _)) -> case tt of
       CTree.Postlude PTUInt -> S . TInteger <$> genUniformRM (0, fromIntegral n)
       _ -> error "Cannot apply le operator to target"
     (CtlOp.Le, _) -> error $ "Invalid controller for .le operator: " <> show controller
-    (CtlOp.Lt, CTree.Literal (VUInt n)) -> case tt of
+    (CtlOp.Lt, CTree.Literal (Value (VUInt n) _)) -> case tt of
       CTree.Postlude PTUInt -> S . TInteger <$> genUniformRM (0, fromIntegral n - 1)
       _ -> error "Cannot apply lt operator to target"
     (CtlOp.Lt, _) -> error $ "Invalid controller for .lt operator: " <> show controller
-    (CtlOp.Size, CTree.Literal (VUInt n)) -> case tt of
+    (CtlOp.Size, CTree.Literal (Value (VUInt n) _)) -> case tt of
       CTree.Postlude PTText -> S . TString <$> genText (fromIntegral n)
       CTree.Postlude PTBytes -> S . TBytes <$> genBytes (fromIntegral n)
       CTree.Postlude PTUInt -> S . TInteger <$> genUniformRM (0, 2 ^ n - 1)
@@ -321,7 +321,7 @@ genForCTree (CTree.Control op target controller) = do
       f <- resolveIfRef from
       t <- resolveIfRef to
       case (f, t) of
-        (CTree.Literal (VUInt f1), CTree.Literal (VUInt t1)) -> case tt of
+        (CTree.Literal (Value (VUInt f1) _), CTree.Literal (Value (VUInt t1) _)) -> case tt of
           CTree.Postlude PTText ->
             genUniformRM (fromIntegral f1, fromIntegral t1)
               >>= (fmap (S . TString) . genText)
@@ -418,17 +418,20 @@ applyOccurenceIndicator (OIBounded mlb mub) oldGen =
     >>= \i -> G <$> replicateM (fromIntegral i) oldGen
 
 genValue :: RandomGen g => Value -> M g Term
-genValue (VUInt i) = pure . TInt $ fromIntegral i
-genValue (VNInt i) = pure . TInt $ fromIntegral (-i)
-genValue (VBignum i) = pure $ TInteger i
-genValue (VFloat16 i) = pure . THalf $ i
-genValue (VFloat32 i) = pure . TFloat $ i
-genValue (VFloat64 i) = pure . TDouble $ i
-genValue (VText t) = pure $ TString t
-genValue (VBytes b) = case Base16.decode b of
+genValue (Value x _) = genValueVariant x
+
+genValueVariant :: RandomGen g => ValueVariant -> M g Term
+genValueVariant (VUInt i) = pure . TInt $ fromIntegral i
+genValueVariant (VNInt i) = pure . TInt $ fromIntegral (-i)
+genValueVariant (VBignum i) = pure $ TInteger i
+genValueVariant (VFloat16 i) = pure . THalf $ i
+genValueVariant (VFloat32 i) = pure . TFloat $ i
+genValueVariant (VFloat64 i) = pure . TDouble $ i
+genValueVariant (VText t) = pure $ TString t
+genValueVariant (VBytes b) = case Base16.decode b of
   Right bHex -> pure $ TBytes bHex
   Left err -> error $ "Unable to parse hex encoded bytestring: " <> err
-genValue (VBool b) = pure $ TBool b
+genValueVariant (VBool b) = pure $ TBool b
 
 --------------------------------------------------------------------------------
 -- Generator functions