Merge pull request #3511 from unisonweb/topic/pretty3451

Fix roundtrip error with lambda as a final argument, which ignores its own argument

parser-typechecker/src/Unison/Syntax/TermPrinter.hs

@@ -119,7 +119,7 @@ data DocLiteralContext
 
      >=12
        let x = (-1)y
-         1z
+           1z
 
      >=11
        ! 11x
@@ -256,19 +256,19 @@ pretty0
             <> pretty0 n (ac (if isBlock x then 0 else 10) Normal im doc) x
       Delay' x
         | Lets' _ _ <- x ->
-            paren (p >= 3) $
-              fmt S.ControlKeyword "do" `PP.hang` pretty0 n (ac 0 Block im doc) x
+          paren (p >= 3) $
+            fmt S.ControlKeyword "do" `PP.hang` pretty0 n (ac 0 Block im doc) x
         | otherwise ->
-            paren (p >= 11 || isBlock x && p >= 3) $
-              fmt S.DelayForceChar (l "'")
-                <> ( case x of
-                       Lets' _ _ -> id
-                       -- Add indentation below if we're opening parens with '(
-                       -- This is in case the contents are a long function application
-                       -- in which case the arguments should be indented.
-                       _ -> PP.indentAfterNewline "  "
-                   )
-                  (pretty0 n (ac 10 Normal im doc) x)
+          paren (p >= 11 || isBlock x && p >= 3) $
+            fmt S.DelayForceChar (l "'")
+              <> ( case x of
+                     Lets' _ _ -> id
+                     -- Add indentation below if we're opening parens with '(
+                     -- This is in case the contents are a long function application
+                     -- in which case the arguments should be indented.
+                     _ -> PP.indentAfterNewline "  "
+                 )
+                (pretty0 n (ac 10 Normal im doc) x)
       List' xs ->
         PP.group $
           (fmt S.DelimiterChar $ l "[") <> optSpace
@@ -319,11 +319,11 @@ pretty0
       -- See `isDestructuringBind` definition.
       Match' scrutinee cs@[MatchCase pat guard (AbsN' vs body)]
         | p < 1 && isDestructuringBind scrutinee cs ->
-            letIntro $
-              PP.lines
-                [ (lhs <> eq) `PP.hang` rhs,
-                  pretty0 n (ac (-1) Block im doc) body
-                ]
+          letIntro $
+            PP.lines
+              [ (lhs <> eq) `PP.hang` rhs,
+                pretty0 n (ac (-1) Block im doc) body
+              ]
         where
           letIntro = case bc of
             Block -> id
@@ -363,9 +363,9 @@ pretty0
       specialCases term go = case (term, binaryOpsPred) of
         (DD.Doc, _)
           | doc == MaybeDoc ->
-              if isDocLiteral term
-                then prettyDoc n im term
-                else pretty0 n (a {docContext = NoDoc}) term
+            if isDocLiteral term
+              then prettyDoc n im term
+              else pretty0 n (a {docContext = NoDoc}) term
         (TupleTerm' [x], _) ->
           let conRef = DD.pairCtorRef
               name = elideFQN im $ PrettyPrintEnv.termName n conRef
@@ -420,17 +420,17 @@ pretty0
         _ -> case (term, nonForcePred) of
           OverappliedBinaryAppPred' f a b r
             | binaryOpsPred f ->
-                -- Special case for overapplied binary op
-                paren
-                  True
-                  ( binaryApps [(f, a)] (pretty0 n (ac 3 Normal im doc) b)
-                      `PP.hang` PP.spacedMap (pretty0 n (ac 10 Normal im doc)) r
-                  )
+              -- Special case for overapplied binary op
+              paren
+                True
+                ( binaryApps [(f, a)] (pretty0 n (ac 3 Normal im doc) b)
+                    `PP.hang` PP.spacedMap (pretty0 n (ac 10 Normal im doc)) r
+                )
           AppsPred' f args ->
             paren (p >= 10) $
               pretty0 n (ac 10 Normal im doc) f
                 `PP.hang` PP.spacedMap (pretty0 n (ac 10 Normal im doc)) args
-          _ -> case (term, nonUnitArgPred) of
+          _ -> case (term, \v -> nonUnitArgPred v && not (isDelay term)) of
             (LamsNamedMatch' [] branches, _) ->
               paren (p >= 3) $
                 PP.group (fmt S.ControlKeyword "cases") `PP.hang` printCase n im doc branches
@@ -439,6 +439,8 @@ pretty0
                 PP.group (varList vs <> fmt S.ControlKeyword " ->") `PP.hang` pretty0 n (ac 2 Block im doc) body
             _ -> go term
 
+      isDelay (Delay' _) = True
+      isDelay _ = False
       sepList = sepList' (pretty0 n (ac 0 Normal im doc))
       sepList' f sep xs = fold $ intersperse sep (map f xs)
       varList = sepList' (PP.text . Var.name) PP.softbreak
@@ -567,8 +569,8 @@ prettyPattern n c@(AmbientContext {imports = im}) p vs patt = case patt of
   Pattern.Text _ t -> (fmt S.TextLiteral $ l $ show t, vs)
   TuplePattern pats
     | length pats /= 1 ->
-        let (pats_printed, tail_vs) = patterns (-1) vs pats
-         in (PP.parenthesizeCommas pats_printed, tail_vs)
+      let (pats_printed, tail_vs) = patterns (-1) vs pats
+       in (PP.parenthesizeCommas pats_printed, tail_vs)
   Pattern.Constructor _ ref [] ->
     (styleHashQualified'' (fmt $ S.TermReference conRef) name, vs)
     where
@@ -798,14 +800,14 @@ prettyBinding0 env a@AmbientContext {imports = im, docContext = doc} v term =
       where
         defnLhs v vs
           | infix' = case vs of
-              x : y : _ ->
-                PP.sep
-                  " "
-                  [ fmt S.Var $ PP.text (Var.name x),
-                    styleHashQualified'' (fmt $ S.HashQualifier v) $ elideFQN im v,
-                    fmt S.Var $ PP.text (Var.name y)
-                  ]
-              _ -> l "error"
+            x : y : _ ->
+              PP.sep
+                " "
+                [ fmt S.Var $ PP.text (Var.name x),
+                  styleHashQualified'' (fmt $ S.HashQualifier v) $ elideFQN im v,
+                  fmt S.Var $ PP.text (Var.name y)
+                ]
+            _ -> l "error"
           | null vs = renderName v
           | otherwise = renderName v `PP.hang` args vs
         args = PP.spacedMap $ fmt S.Var . PP.text . Var.name
@@ -1431,7 +1433,7 @@ unLetBlock t = rec t
       Just (_isTop, bindings, body) -> case rec body of
         Just (innerBindings, innerBody)
           | dontIntersect bindings innerBindings ->
-              Just (bindings ++ innerBindings, innerBody)
+            Just (bindings ++ innerBindings, innerBody)
         _ -> Just (bindings, body)
     nonrec t = case unLet t of
       Nothing -> Nothing
@@ -1440,7 +1442,7 @@ unLetBlock t = rec t
          in case rec body of
               Just (innerBindings, innerBody)
                 | dontIntersect bindings innerBindings ->
-                    Just (bindings ++ innerBindings, innerBody)
+                  Just (bindings ++ innerBindings, innerBody)
               _ -> Just (bindings, body)
 
 pattern LamsNamedMatch' ::
@@ -1493,7 +1495,7 @@ unLamsMatch' t = case unLamsUntilDelay' t of
     | -- if `v1'` is referenced in any of the branches, we can't use lambda case
       -- syntax as we need to keep the `v1'` name that was introduced
       (v1 == v1') && Set.notMember v1' (Set.unions $ freeVars <$> branches) ->
-        Just (reverse vs, [([p], guard, body) | MatchCase p guard body <- branches])
+      Just (reverse vs, [([p], guard, body) | MatchCase p guard body <- branches])
   -- x y z -> match (x,y,z) with (pat1, pat2, pat3) -> ...
   --   becomes
   -- cases pat1 pat2 pat3 -> ...`
@@ -1506,7 +1508,7 @@ unLamsMatch' t = case unLamsUntilDelay' t of
         all notFree (take len vs)
         && all isRightArity branches
         && len /= 0 -> -- all patterns need to match arity of scrutes
-        Just (reverse (drop len vs), branches')
+      Just (reverse (drop len vs), branches')
     where
       isRightArity (MatchCase (TuplePattern ps) _ _) = length ps == len
       isRightArity (MatchCase {}) = False
@@ -1745,7 +1747,7 @@ toDocExample' suffix ppe (Apps' (Ref' r) [Nat' n, l@(LamsNamed' vs tm)])
   | nameEndsWith ppe suffix r,
     ABT.freeVars l == mempty,
     ok tm =
-      Just (lam' (ABT.annotation l) (drop (fromIntegral n + 1) vs) tm)
+    Just (lam' (ABT.annotation l) (drop (fromIntegral n + 1) vs) tm)
   where
     ok (Apps' f _) = ABT.freeVars f == mempty
     ok tm = ABT.freeVars tm == mempty
@@ -1759,9 +1761,9 @@ toDocTransclude _ _ = Nothing
 toDocLink :: Ord v => PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Either Reference Referent)
 toDocLink ppe (App' (Ref' r) tm)
   | nameEndsWith ppe ".docLink" r = case tm of
-      (toDocEmbedTermLink ppe -> Just tm) -> Just (Right tm)
-      (toDocEmbedTypeLink ppe -> Just tm) -> Just (Left tm)
-      _ -> Nothing
+    (toDocEmbedTermLink ppe -> Just tm) -> Just (Right tm)
+    (toDocEmbedTypeLink ppe -> Just tm) -> Just (Left tm)
+    _ -> Nothing
 toDocLink _ _ = Nothing
 
 toDocNamedLink :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation, Term3 v PrintAnnotation)
@@ -1800,7 +1802,7 @@ toDocSourceAnnotations _ppe _tm = Just [] -- todo fetch annotations
 toDocSourceElement :: Ord v => PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Either Reference Referent, [Referent])
 toDocSourceElement ppe (Apps' (Ref' r) [tm, toDocSourceAnnotations ppe -> Just annotations])
   | nameEndsWith ppe ".docSourceElement" r =
-      (,annotations) <$> ok tm
+    (,annotations) <$> ok tm
   where
     ok tm =
       (Right <$> toDocEmbedTermLink ppe tm)
@@ -1815,9 +1817,9 @@ toDocSource' ::
   Maybe [(Either Reference Referent, [Referent])]
 toDocSource' suffix ppe (App' (Ref' r) (List' tms))
   | nameEndsWith ppe suffix r =
-      case [tm | Just tm <- toDocSourceElement ppe <$> toList tms] of
-        tms' | length tms' == length tms -> Just tms'
-        _ -> Nothing
+    case [tm | Just tm <- toDocSourceElement ppe <$> toList tms] of
+      tms' | length tms' == length tms -> Just tms'
+      _ -> Nothing
 toDocSource' _ _ _ = Nothing
 
 toDocSource,
@@ -1847,17 +1849,17 @@ toDocEmbedAnnotation _ _ = Nothing
 toDocEmbedAnnotations :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
 toDocEmbedAnnotations ppe (App' (Ref' r) (List' tms))
   | nameEndsWith ppe ".docEmbedAnnotations" r =
-      case [ann | Just ann <- toDocEmbedAnnotation ppe <$> toList tms] of
-        tms' | length tms' == length tms -> Just tms'
-        _ -> Nothing
+    case [ann | Just ann <- toDocEmbedAnnotation ppe <$> toList tms] of
+      tms' | length tms' == length tms -> Just tms'
+      _ -> Nothing
 toDocEmbedAnnotations _ _ = Nothing
 
 toDocSignature :: Ord v => PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe [Referent]
 toDocSignature ppe (App' (Ref' r) (List' tms))
   | nameEndsWith ppe ".docSignature" r =
-      case [tm | Just tm <- toDocEmbedSignatureLink ppe <$> toList tms] of
-        tms' | length tms' == length tms -> Just tms'
-        _ -> Nothing
+    case [tm | Just tm <- toDocEmbedSignatureLink ppe <$> toList tms] of
+      tms' | length tms' == length tms -> Just tms'
+      _ -> Nothing
 toDocSignature _ _ = Nothing
 
 toDocBulletedList :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]

parser-typechecker/tests/Unison/Test/Syntax/TermPrinter.hs

@@ -234,7 +234,7 @@ test =
           \else c) with\n\
           \  112 -> x", -- dodgy layout.  note #517
         tc "handle bar with Pair 1 1",
-        tc "handle bar with x -> foo",
+        tcDiff "handle bar with x -> foo" "handle bar with 'foo",
         tcDiffRtt
           True
           "let\n\
@@ -399,8 +399,8 @@ test =
         tcDiff "'('bar)" "''bar",
         tcDiff "!('bar)" "!'bar",
         tcDiff "'(!foo)" "'!foo",
-        tc "x -> '(y -> 'z)",
-        tc "'(x -> '(y -> z))",
+        tcDiff "x -> '(y -> 'z)" "''''z",
+        tcDiff "'(x -> '(y -> z))" "''''z",
         tc "(\"a\", 2)",
         tc "(\"a\", 2, 2.0)",
         tcDiff "(2)" "2",

unison-src/transcripts-round-trip/main.md

@@ -441,3 +441,32 @@ bar3 x = do
 ```ucm
 .> load scratch.u
 ```
+
+# Lambda as the last argument where the bound var is not free in the body
+
+If a lambda's argument is not free in the body, the term printer counts this as
+a "delay" instead of a lambda. This test makes sure that detecting this
+condition lines up with the printing, so we don't detect a delay but then
+go ahead and print it as a normal lambda.
+
+```unison:hide
+(+) a b = ##Nat.+ a b
+
+afun x f = f x
+
+roundtripLastLam =
+  afun "foo" (n -> let
+    1 + 1
+    3
+  )
+```
+
+```ucm
+.> add
+.> edit roundtripLastLam afun
+.> undo
+```
+
+```ucm
+.> load scratch.u
+```