Improve comma formatting

src/Juvix/Compiler/Concrete/Language.hs

@@ -31,7 +31,9 @@ import Juvix.Data.Ape.Base as Ape
 import Juvix.Data.Fixity
 import Juvix.Data.Keyword
 import Juvix.Data.NameKind
+import Juvix.Parser.Lexer (isDelimiterStr)
 import Juvix.Prelude hiding (show)
+import Juvix.Prelude.Pretty (prettyText)
 import Prelude (show)
 
 data Stage
@@ -1312,6 +1314,7 @@ instance IsApe InfixApplication Expression where
         { _infixFixity = getFixity i,
           _infixLeft = toApe l,
           _infixRight = toApe r,
+          _infixIsComma = isDelimiterStr (prettyText (identifierName op ^. S.nameConcrete)),
           _infixOp = ExpressionIdentifier op
         }
 

src/Juvix/Compiler/Concrete/Pretty/Base.hs

@@ -530,7 +530,7 @@ instance (SingI s) => PrettyCode (FunctionClause s) where
       clauseOwnerFunction'
         <+?> clausePatterns'
         <+> kwAssign
-        <+> oneLineOrNext clauseBody'
+          <> oneLineOrNext clauseBody'
 
 instance (SingI s) => PrettyCode (AxiomDef s) where
   ppCode AxiomDef {..} = do

src/Juvix/Compiler/Concrete/Print/Base.hs

@@ -193,12 +193,13 @@ instance PrettyPrint (TypeSignature 'Scoped) where
     doc'
       ?<> builtin'
       <?+> termin'
-        ?<> hang
-          ( name'
-              <+> noLoc P.kwColon
-              <+> type'
-              <+?> body'
-          )
+        ?<> ( name'
+                <+> noLoc P.kwColon
+                <+> nest
+                  ( type'
+                      <+?> body'
+                  )
+            )
 
 instance PrettyPrint Pattern where
   ppCode = ppMorpheme
@@ -274,7 +275,7 @@ instance PrettyPrint (FunctionClause 'Scoped) where
     clauseFun'
       <+?> clausePatterns'
       <+> noLoc P.kwAssign
-      <+> oneLineOrNext clauseBody'
+        <> oneLineOrNext clauseBody'
 
 ppPatternAtom :: forall r. (Members '[Reader Options, ExactPrint] r) => PatternArg -> Sem r ()
 ppPatternAtom pat =
@@ -300,7 +301,7 @@ instance PrettyPrint (InductiveConstructorDef 'Scoped) where
     let constructorName' = region (P.annDef _constructorName) (ppCode _constructorName)
         constructorType' = ppCode _constructorType
         doc' = ppCode <$> _constructorDoc
-    hang (pipeHelper <+> doc' ?<> constructorName' <+> noLoc P.kwColon <+> constructorType')
+    nest (pipeHelper <+> doc' ?<> constructorName' <+> noLoc P.kwColon <+> constructorType')
     where
       -- we use this helper so that comments appear before the first optional pipe if the pipe was omitted
       pipeHelper :: Sem r ()

src/Juvix/Data/Ape/Base.hs

@@ -19,11 +19,17 @@ data Cape a
   | CapeAppChain (AppChain a)
   | CapeUChain (UChain a)
 
+data Link a = Link
+  { _linkOp :: a,
+    _linkIsComma :: Bool,
+    _linkArg :: Cape a
+  }
+
 -- | A binary chain of application with the same fixity
 data Chain a = Chain
   { _chainFixity :: Fixity,
     _chainHead :: Cape a,
-    _chainLinks :: NonEmpty (a, Cape a)
+    _chainLinks :: NonEmpty (Link a)
   }
 
 data AppChain a = AppChain
@@ -52,6 +58,10 @@ data Infix a = Infix
   { _infixFixity :: Fixity,
     _infixLeft :: Ape a,
     _infixOp :: a,
+    -- | When isComma is set to True, the operator will be printed without left
+    -- space if the chain fits in the same line, otherwise it will behave as a
+    -- regular infix operator.
+    _infixIsComma :: Bool,
     _infixRight :: Ape a
   }
 
@@ -67,6 +77,7 @@ makeLenses ''AppChain
 makeLenses ''UChain
 makeLenses ''Infix
 makeLenses ''Postfix
+makeLenses ''Link
 
 toCape :: forall a. Ape a -> Cape a
 toCape = \case
@@ -103,7 +114,7 @@ toCape = \case
               }
 
     unfoldInfix :: Infix a -> Chain a
-    unfoldInfix (Infix fx l op r)
+    unfoldInfix (Infix fx l op isComma r)
       | isLeftAssoc fx = leftAssoc
       | isRightAssoc fx = rightAssoc
       | otherwise = noAssoc
@@ -113,30 +124,30 @@ toCape = \case
           Chain
             { _chainFixity = fx,
               _chainHead = toCape l,
-              _chainLinks = pure (op, toCape r)
+              _chainLinks = pure (Link op isComma (toCape r))
             }
 
         rightAssoc :: Chain a
         rightAssoc =
           Chain
             { _chainFixity = fx,
               _chainHead = toCape l,
-              _chainLinks = go op r
+              _chainLinks = go op isComma r
             }
           where
-            go :: a -> Ape a -> NonEmpty (a, Cape a)
-            go prevOp = \case
-              ApeInfix (Infix fx' l' op' r')
-                | fx == fx' -> pure (prevOp, toCape l') <> go op' r'
-              e -> pure (prevOp, toCape e)
+            go :: a -> Bool -> Ape a -> NonEmpty (Link a)
+            go prevOp prevIsComma = \case
+              ApeInfix (Infix fx' l' op' isComma' r')
+                | fx == fx' -> pure (Link prevOp prevIsComma (toCape l')) <> go op' isComma' r'
+              e -> pure (Link prevOp prevIsComma (toCape e))
 
         leftAssoc :: Chain a
-        leftAssoc = go (pure (op, toCape r)) l
+        leftAssoc = go (pure (Link op isComma (toCape r))) l
           where
-            go :: NonEmpty (a, Cape a) -> Ape a -> Chain a
+            go :: NonEmpty (Link a) -> Ape a -> Chain a
             go ac = \case
-              ApeInfix (Infix fx' l' op' r')
-                | fx == fx' -> go (pure (op', toCape r') <> ac) l'
+              ApeInfix (Infix fx' l' op' isComma' r')
+                | fx == fx' -> go (pure (Link op' isComma' (toCape r')) <> ac) l'
               e ->
                 Chain
                   { _chainFixity = fx,

src/Juvix/Data/Ape/Pretty.hs

@@ -38,32 +38,38 @@ ppCape = \case
   CapeAppChain c -> ppAppChain c
   CapeUChain c -> ppUChain c
 
-chain :: Doc CodeAnn -> NonEmpty (Doc CodeAnn) -> Doc CodeAnn
-chain f' args' = PP.group (nest' (vsep (f' : toList args')))
+chain :: Doc CodeAnn -> Doc CodeAnn
+chain = PP.group . nest'
 
 ppAppChain :: forall a r. (Members '[Reader (ApeParams a)] r) => AppChain a -> Sem r (Doc CodeAnn)
 ppAppChain (AppChain f links) = do
   f' <- ppLinkExpr fx f
   args' <- mapM (ppLinkExpr fx) links
-  return $ chain f' args'
+  return $ chain (vsep (f' : toList args'))
   where
     fx :: Precedence
     fx = appFixity ^. fixityPrecedence
 
 ppChain :: forall a r. (Members '[Reader (ApeParams a)] r) => Chain a -> Sem r (Doc CodeAnn)
 ppChain (Chain opFix f links) = do
   f' <- ppLinkExpr fx f
-  args' <- mapM ppLink links
-  return $ chain f' args'
+  chain <$> ppLinks f' (toList links)
   where
+    ppLinks :: Doc CodeAnn -> [Link a] -> Sem r (Doc CodeAnn)
+    ppLinks acc = \case
+      [] -> return acc
+      l : ls -> do
+        let sepHelper a b = a <> sp <> b
+            sp
+              | l ^. linkIsComma = line'
+              | otherwise = line
+        pp <- asks (^. apePP)
+        let op' = pp (l ^. linkOp)
+        a' <- ppLinkExpr fx (l ^. linkArg)
+        ppLinks (acc `sepHelper` op' <+> a') ls
+
     fx :: Precedence
     fx = opFix ^. fixityPrecedence
-    ppLink :: (a, Cape a) -> Sem r (Doc CodeAnn)
-    ppLink (op, a) = do
-      pp <- asks (^. apePP)
-      let op' = pp op
-      a' <- ppLinkExpr fx a
-      return (op' <+> a')
 
 ppUChain :: forall a r. (Members '[Reader (ApeParams a)] r) => UChain a -> Sem r (Doc CodeAnn)
 ppUChain (UChain opFix f links) = do

src/Juvix/Data/Effect/ExactPrint/Base.hs

@@ -102,7 +102,7 @@ morpheme' loc doc = do
     popComment = do
       cs <- gets (^. builderComments)
       case cs of
-        (h : hs)
+        h : hs
           | cmp h -> do
               modify' (set builderComments hs)
               return (Just h)

src/Juvix/Parser/Lexer.hs

@@ -122,6 +122,14 @@ morpheme = morpheme' (const False)
 delimiterSymbols :: [Char]
 delimiterSymbols = ","
 
+isDelimiterStr :: Text -> Bool
+isDelimiterStr t = case unpack t of
+  [c] -> isDelimiter c
+  _ -> False
+
+isDelimiter :: Char -> Bool
+isDelimiter = (`elem` delimiterSymbols)
+
 validFirstChar :: Char -> Bool
 validFirstChar c = not (isNumber c || isSpace c || (c `elem` reservedSymbols))
 

src/Juvix/Prelude/Pretty.hs

@@ -122,7 +122,7 @@ hang' :: Doc ann -> Doc ann
 hang' = hang 2
 
 oneLineOrNext :: Doc ann -> Doc ann
-oneLineOrNext x = PP.group (flatAlt (line <> indent' x) x)
+oneLineOrNext x = PP.group (flatAlt (line <> indent' x) (space <> x))
 
 ordinal :: Int -> Doc a
 ordinal = \case

test/Asm/Run/Base.hs

@@ -37,7 +37,7 @@ asmRunAssertion' tab expectedFile step = do
                     actualOutput <- TIO.readFile (toFilePath outputFile)
                     step "Compare expected and actual program output"
                     expected <- TIO.readFile (toFilePath expectedFile)
-                    assertEqDiff ("Check: RUN output = " <> toFilePath expectedFile) actualOutput expected
+                    assertEqDiffText ("Check: RUN output = " <> toFilePath expectedFile) actualOutput expected
             )
         Nothing -> assertFailure "no 'main' function"
 

test/BackendC/Base.hs

@@ -50,7 +50,7 @@ wasmClangAssertion WASMInfo {..} mainFile expectedFile step = do
   step "Compile C with wasm standalone runtime"
   actualStandalone <- clangCompile standaloneArgs p _wasmInfoActual step
   step "Compare expected and actual program output"
-  assertEqDiff ("Check: WASM output = " <> toFilePath expectedFile) actualStandalone expected
+  assertEqDiffText ("Check: WASM output = " <> toFilePath expectedFile) actualStandalone expected
 
 wasiClangAssertion :: StdlibMode -> Path Abs File -> Path Abs File -> Text -> ((String -> IO ()) -> Assertion)
 wasiClangAssertion stdlibMode mainFile expectedFile stdinText step = do
@@ -74,12 +74,12 @@ wasiClangAssertion stdlibMode mainFile expectedFile stdinText step = do
   step "Compile C with standalone runtime"
   actualStandalone <- clangCompile (wasiStandaloneArgs sysrootPath) p execute step
   step "Compare expected and actual program output"
-  assertEqDiff ("check: WASM output = " <> toFilePath expectedFile) actualStandalone expected
+  assertEqDiffText ("check: WASM output = " <> toFilePath expectedFile) actualStandalone expected
 
   step "Compile C with libc runtime"
   actualLibc <- clangCompile (libcArgs sysrootPath) p execute step
   step "Compare expected and actual program output"
-  assertEqDiff ("check: WASM output = " <> toFilePath expectedFile) actualLibc expected
+  assertEqDiffText ("check: WASM output = " <> toFilePath expectedFile) actualLibc expected
 
 builtinRuntime :: Path Abs Dir
 builtinRuntime = absDir $(makeRelativeToProject "c-runtime/builtins" >>= strToExp)

test/Base.hs

@@ -16,7 +16,6 @@ import Juvix.Prelude
 import Juvix.Prelude.Env
 import Test.Tasty
 import Test.Tasty.HUnit
-import Text.Show.Pretty hiding (Html)
 
 data AssertionDescr
   = Single Assertion
@@ -49,16 +48,22 @@ mkTest TestDescr {..} = case _testAssertion of
   Single assertion -> testCase _testName $ withCurrentDir _testRoot assertion
   Steps steps -> testCaseSteps _testName (withCurrentDir _testRoot . steps)
 
-assertEqDiff :: (Eq a, Show a) => String -> a -> a -> Assertion
-assertEqDiff msg a b
+assertEqDiffText :: String -> Text -> Text -> Assertion
+assertEqDiffText = assertEqDiff unpack
+
+assertEqDiff :: Eq a => (a -> String) -> String -> a -> a -> Assertion
+assertEqDiff show_ msg a b
   | a == b = return ()
   | otherwise = do
       putStrLn (pack $ ppDiff (getGroupedDiff pa pb))
       putStrLn "End diff"
       Monad.fail msg
   where
-    pa = lines $ ppShow a
-    pb = lines $ ppShow b
+    pa = lines $ show_ a
+    pb = lines $ show_ b
+
+assertEqDiffShow :: (Eq a, Show a) => String -> a -> a -> Assertion
+assertEqDiffShow = assertEqDiff show
 
 assertCmdExists :: Path Rel File -> Assertion
 assertCmdExists cmd =

test/Core/Asm/Base.hs

@@ -46,7 +46,7 @@ coreAsmAssertion mainFile expectedFile step = do
     Right (_, Nothing) -> do
       step "Empty program: compare expected and actual program output"
       expected <- TIO.readFile (toFilePath expectedFile)
-      assertEqDiff ("Check: EVAL output = " <> toFilePath expectedFile) "" expected
+      assertEqDiffText ("Check: EVAL output = " <> toFilePath expectedFile) "" expected
     Right (tabIni, Just node) -> do
       step "Translate"
       let tab = Asm.fromCore $ Stripped.fromCore $ toStripped $ setupMainFunction tabIni node

test/Core/Compile/Base.hs

@@ -57,6 +57,6 @@ coreCompileAssertion mainFile expectedFile step = do
     Right (_, Nothing) -> do
       step "Empty program: compare expected and actual program output"
       expected <- TIO.readFile (toFilePath expectedFile)
-      assertEqDiff ("Check: EVAL output = " <> toFilePath expectedFile) "" expected
+      assertEqDiffText ("Check: EVAL output = " <> toFilePath expectedFile) "" expected
     Right (tabIni, Just node) ->
       coreCompileAssertion' (setupMainFunction tabIni node) mainFile expectedFile step

test/Core/Eval/Base.hs

@@ -28,7 +28,7 @@ coreEvalAssertion mainFile expectedFile trans testTrans step = do
     Right (_, Nothing) -> do
       step "Compare expected and actual program output"
       expected <- TIO.readFile (toFilePath expectedFile)
-      assertEqDiff ("Check: EVAL output = " <> toFilePath expectedFile) "" expected
+      assertEqDiffText ("Check: EVAL output = " <> toFilePath expectedFile) "" expected
     Right (tabIni, Just node) -> do
       let tab = applyTransformations trans (setupMainFunction tabIni node)
       testTrans tab
@@ -51,7 +51,7 @@ coreEvalAssertion mainFile expectedFile trans testTrans step = do
                 actualOutput <- TIO.readFile (toFilePath outputFile)
                 step "Compare expected and actual program output"
                 expected <- TIO.readFile (toFilePath expectedFile)
-                assertEqDiff ("Check: EVAL output = " <> toFilePath expectedFile) actualOutput expected
+                assertEqDiffText ("Check: EVAL output = " <> toFilePath expectedFile) actualOutput expected
         )
 
 coreEvalErrorAssertion :: Path Abs File -> (String -> IO ()) -> Assertion