Determine if a delayed term is a block

parser-typechecker/src/Unison/TermPrinter.hs

@@ -87,20 +87,20 @@ data BlockContext
   -- This ABT node is at the top level of a TermParser.block.
   = Block
   | Normal
-  deriving (Eq)
+  deriving (Eq, Show)
 
 data InfixContext
   -- This ABT node is an infix operator being used in infix position.
   = Infix
   | NonInfix
-  deriving (Eq)
+  deriving (Eq, Show)
 
 data DocLiteralContext
   -- We won't try and render this ABT node or anything under it as a [: @Doc literal :]
   = NoDoc
   -- We'll keep checking as we recurse down
   | MaybeDoc
-  deriving (Eq)
+  deriving (Eq, Show)
 
 {- Explanation of precedence handling
 
@@ -238,9 +238,13 @@ pretty0
         pblock tm = let (im', uses) = calcImports im tm
                     in uses $ [pretty0 n (ac 0 Block im' doc) tm]
     App' x (Constructor' DD.UnitRef 0) ->
-      paren (p >= 11) $ (fmt S.DelayForceChar $ l "!") <> pretty0 n (ac 11 Normal im doc) x
-    Delay' x  ->
-      paren (p >= 11) $ (fmt S.DelayForceChar $ l "'") <> pretty0 n (ac 11 Normal im doc) x
+      paren (p >= 11 || isBlock x && p >= 3)  $
+        fmt S.DelayForceChar (l "!")
+        <> pretty0 n (ac (if isBlock x then 0 else 10) Normal im doc) x
+    Delay' x ->
+      paren (p >= 11 || isBlock x && p >= 3) $
+        fmt S.DelayForceChar (l "'")
+        <> pretty0 n (ac (if isBlock x then 0 else 10) Normal im doc) x
     List' xs -> PP.group $
       (fmt S.DelimiterChar $ l "[") <> optSpace
           <> intercalateMap ((fmt S.DelimiterChar $ l ",") <> PP.softbreak <> optSpace <> optSpace)
@@ -368,7 +372,7 @@ pretty0
            -> ([Pretty SyntaxText] -> Pretty SyntaxText)
            -> Pretty SyntaxText
   printLet elideUnit sc bs e im uses =
-    paren ((sc /= Block) && p >= 3)
+    paren ((sc /= Block) && p >= 12)
       $  letIntro
       $  uses [PP.lines (map printBinding bs ++ body e)]
    where
@@ -379,7 +383,7 @@ pretty0
       else prettyBinding0 n (ac (-1) Normal im doc) (HQ.unsafeFromVar v) binding
     letIntro = case sc of
       Block  -> id
-      Normal -> \x -> fmt S.ControlKeyword "let" `PP.hang` x
+      Normal -> \x -> (fmt S.ControlKeyword "let") `PP.hang` x
 
   -- This predicate controls which binary functions we render as infix
   -- operators.  At the moment the policy is just to render symbolic
@@ -421,7 +425,7 @@ pretty0
       _      -> undefined
     ps = join $ [ r a f | (a, f) <- reverse xs ]
     r a f =
-      [ pretty0 n (ac 3 Normal im doc)                          a
+      [ pretty0 n (ac (if isBlock a then 12 else 3) Normal im doc) a
       , pretty0 n (AmbientContext 10 Normal Infix im doc False) f
       ]
 
@@ -1176,6 +1180,15 @@ isDestructuringBind scrutinee [MatchCase pat _ (ABT.AbsN' vs _)]
       Pattern.Unbound _ -> False
 isDestructuringBind _ _ = False
 
+isBlock :: Ord v => Term2 vt at ap v a -> Bool
+isBlock tm =
+  case tm of
+    If' _ _ _ -> True
+    Handle' _ _ -> True
+    Match' _ _ -> True
+    LetBlock _ _ -> True
+    _ -> False
+
 pattern LetBlock bindings body <- (unLetBlock -> Just (bindings, body))
 
 -- Collects nested let/let rec blocks into one minimally nested block.

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

@@ -344,13 +344,13 @@ test = scope "termprinter" $ tests
   , tc "!f a"
   , tcDiff "f () a ()" "!(!f a)"
   , tcDiff "f a b ()" "!(f a b)"
-  , tcDiff "!f ()" "!(!f)"
-  , tc "!(!foo)"
+  , tcDiff "!f ()" "!!f"
+  , tcDiff "!(!foo)" "!!foo"
   , tc "'bar"
   , tc "'(bar a b)"
-  , tc "'('bar)"
-  , tc "!('bar)"
-  , tc "'(!foo)"
+  , tcDiff "'('bar)" "''bar"
+  , tcDiff "!('bar)" "!'bar"
+  , tcDiff "'(!foo)" "'!foo"
   , tc "x -> '(y -> 'z)"
   , tc "'(x -> '(y -> z))"
   , tc "(\"a\", 2)"

parser-typechecker/transcripts/Transcripts.hs

@@ -109,8 +109,6 @@ test config = do
     $ "unison-src" </> "transcripts"
   buildTests config testBuilder
     $ "unison-src" </> "transcripts-using-base"
-  buildTests config testBuilder
-    $ "unison-src" </> "transcripts-round-trip"
   buildTests config testBuilder'
     $ "unison-src" </> "transcripts" </> "errors"
   cleanup

unison-core/src/Unison/Term.hs

@@ -443,7 +443,6 @@ unDelay tm = case ABT.out tm of
     |  Set.notMember v (ABT.freeVars body)
     -> Just body
   _ -> Nothing
-
 pattern LamNamed' v body <- (ABT.out -> ABT.Tm (Lam (ABT.Term _ _ (ABT.Abs v body))))
 pattern LamsNamed' vs body <- (unLams' -> Just (vs, body))
 pattern LamsNamedOpt' vs body <- (unLamsOpt' -> Just (vs, body))

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

@@ -595,7 +595,7 @@ x = '(let
     
     x : 'Optional Nat
     x =
-      '(let
+      ('let
         abort
         0) |> toOptional