Make pretty Terms format prettier (#1464)

- improve layout of terms:
  - break lines on binds, unless it fits on one line
  - lambdas go on same line, but the body _can_ go to next line
  - def and let can have long body on next line (indented for def)
  - parens and braces have body indented if it does not fit on line
- closes #11

Example using `--format` from #1459:

```
> cabal run swarm -O0 -- format scenarios/Challenges/_blender/patrol-clockwise.sw                          
def forever = \c. c; force forever c end;
def encircle = \lDir. \rDir.
  turn lDir;
  b <- blocked;
  if b {turn rDir} {wait 1};
  fwBlocked <- blocked;
  if fwBlocked {turn rDir} {move}
end;
def patrolCW = force forever (force encircle right left) end;
force patrolCW
```

data/entities.yaml

@@ -794,18 +794,16 @@
   - Equipping treads on a robot allows it to move and turn.
   - The `move` command moves the robot forward one unit.
   - |
-    Example:
-    ```
-    move; move; // move two units
-    ```
+    For example to move two units:
+  - |
+    `move; move;`
   - The `turn` command takes a direction as an argument, which
     can be either absolute (north, west, east, south) or relative
     (left, right, forward, back, down).
   - |
     Example:
-    ```
-    move; turn left; move; turn right
-    ```
+  - |
+    `move; turn left; move; turn right`
   capabilities: [move, turn]
   properties: [portable]
 
@@ -1229,16 +1227,15 @@
   description:
   - |
     A compass gives a robot the ability to orient using the cardinal
-    directions north, south, west, and east; for example, `turn west;
-    move; turn north`.
+    directions north, south, west, and east. For example:
+  - |
+    `turn west; move; turn north`
   - |
     It also enables the `heading : cmd dir` command, which returns the
     robot's current heading. For example, the following code moves
     east and then restores the same heading as before:
   - |
-    ```
-    d <- heading; turn east; move; turn d
-    ```
+    `d <- heading; turn east; move; turn d`
   properties: [portable]
   capabilities: [orient]
 

src/Swarm/Language/Pretty.hs

@@ -61,14 +61,18 @@ prettyString :: (PrettyPrec a) => a -> String
 prettyString = docToString . ppr
 
 -- | Optionally surround a document with parentheses depending on the
---   @Bool@ argument.
+--   @Bool@ argument and if it does not fit on line, indent the lines,
+--   with the parens on separate lines.
 pparens :: Bool -> Doc ann -> Doc ann
-pparens True = parens
+pparens True = group . encloseWithIndent 2 lparen rparen
 pparens False = id
 
+encloseWithIndent :: Int -> Doc ann -> Doc ann -> Doc ann -> Doc ann
+encloseWithIndent i l r = nest i . enclose (l <> line') (nest (-2) $ line' <> r)
+
 -- | Surround a document with backticks.
 bquote :: Doc ann -> Doc ann
-bquote d = "`" <> d <> "`"
+bquote = group . enclose "`" "`"
 
 -- | Turn a 'Show' instance into a @Doc@, lowercasing it in the
 --   process.
@@ -78,6 +82,8 @@ prettyShowLow = pretty . showLowT
 --------------------------------------------------
 -- Bullet lists
 
+data Prec a = Prec Int a
+
 data BulletList i = BulletList
   { bulletListHeader :: forall a. Doc a
   , bulletListItems :: [i]
@@ -180,10 +186,9 @@ instance PrettyPrec Term where
   prettyPrec p (TRequire n e) = pparens (p > 10) $ "require" <+> pretty n <+> ppr @Term (TText e)
   prettyPrec p (TRequirements _ e) = pparens (p > 10) $ "requirements" <+> ppr e
   prettyPrec _ (TVar s) = pretty s
-  prettyPrec _ (TDelay _ t) = braces $ ppr t
+  prettyPrec _ (TDelay _ t) = group . encloseWithIndent 2 lbrace rbrace $ ppr t
   prettyPrec _ t@TPair {} = prettyTuple t
-  prettyPrec _ (TLam x mty body) =
-    "\\" <> pretty x <> maybe "" ((":" <>) . ppr) mty <> "." <+> ppr body
+  prettyPrec _ t@(TLam {}) = prettyLambdas t
   -- Special handling of infix operators - ((+) 2) 3 --> 2 + 3
   prettyPrec p (TApp t@(TApp (TConst c) l) r) =
     let ci = constInfo c
@@ -207,21 +212,33 @@ instance PrettyPrec Term where
             _ -> prettyPrecApp p t1 t2
     _ -> prettyPrecApp p t1 t2
   prettyPrec _ (TLet _ x mty t1 t2) =
-    hsep $
-      ["let", pretty x]
-        ++ maybe [] (\ty -> [":", ppr ty]) mty
-        ++ ["=", ppr t1, "in", ppr t2]
+    group . vsep $
+      [ hsep $
+          ["let", pretty x]
+            ++ maybe [] (\ty -> [":", ppr ty]) mty
+            ++ ["=", ppr t1, "in"]
+      , ppr t2
+      ]
   prettyPrec _ (TDef _ x mty t1) =
-    hsep $
-      ["def", pretty x]
-        ++ maybe [] (\ty -> [":", ppr ty]) mty
-        ++ ["=", ppr t1, "end"]
+    let (t1rest, t1lams) = unchainLambdas t1
+     in group . vsep $
+          [ nest 2 $
+              vsep
+                [ hsep $
+                    ["def", pretty x]
+                      ++ maybe [] (\ty -> [":", ppr ty]) mty
+                      ++ ["="]
+                      ++ map prettyLambda t1lams
+                , ppr t1rest
+                ]
+          , "end"
+          ]
   prettyPrec p (TBind Nothing t1 t2) =
     pparens (p > 0) $
-      prettyPrec 1 t1 <> ";" <+> prettyPrec 0 t2
+      prettyPrec 1 t1 <> ";" <> line <> prettyPrec 0 t2
   prettyPrec p (TBind (Just x) t1 t2) =
     pparens (p > 0) $
-      pretty x <+> "<-" <+> prettyPrec 1 t1 <> ";" <+> prettyPrec 0 t2
+      pretty x <+> "<-" <+> prettyPrec 1 t1 <> ";" <> line <> prettyPrec 0 t2
   prettyPrec _ (TRcd m) = brackets $ hsep (punctuate "," (map prettyEquality (M.assocs m)))
   prettyPrec _ (TProj t x) = prettyPrec 11 t <> "." <> pretty x
   prettyPrec p (TAnnotate t pt) =
@@ -233,7 +250,7 @@ prettyEquality (x, Nothing) = pretty x
 prettyEquality (x, Just t) = pretty x <+> "=" <+> ppr t
 
 prettyTuple :: Term -> Doc a
-prettyTuple = pparens True . hsep . punctuate "," . map ppr . unnestTuple
+prettyTuple = tupled . map ppr . unnestTuple
  where
   unnestTuple (TPair t1 t2) = t1 : unnestTuple t2
   unnestTuple t = [t]
@@ -249,6 +266,19 @@ appliedTermPrec (TApp f _) = case f of
   _ -> appliedTermPrec f
 appliedTermPrec _ = 10
 
+prettyLambdas :: Term -> Doc a
+prettyLambdas t = hsep (prettyLambda <$> lms) <> softline <> ppr rest
+ where
+  (rest, lms) = unchainLambdas t
+
+unchainLambdas :: Term -> (Term, [(Var, Maybe Type)])
+unchainLambdas = \case
+  TLam x mty body -> ((x, mty) :) <$> unchainLambdas body
+  body -> (body, [])
+
+prettyLambda :: (Pretty a1, PrettyPrec a2) => (a1, Maybe a2) -> Doc ann
+prettyLambda (x, mty) = "\\" <> pretty x <> maybe "" ((":" <>) . ppr) mty <> "."
+
 ------------------------------------------------------------
 -- Error messages
 
@@ -271,37 +301,42 @@ prettyTypeErr code (CTE l tcStack te) =
   showLoc (r, c) = pretty r <> ":" <> pretty c
 
 instance PrettyPrec TypeErr where
-  prettyPrec _ (UnifyErr ty1 ty2) =
-    "Can't unify" <+> ppr ty1 <+> "and" <+> ppr ty2
-  prettyPrec _ (Mismatch Nothing (getJoin -> (ty1, ty2))) =
-    "Type mismatch: expected" <+> ppr ty1 <> ", but got" <+> ppr ty2
-  prettyPrec _ (Mismatch (Just t) (getJoin -> (ty1, ty2))) =
-    nest 2 . vcat $
-      [ "Type mismatch:"
-      , "From context, expected" <+> bquote (ppr t) <+> "to" <+> typeDescription Expected ty1 <> ","
-      , "but it" <+> typeDescription Actual ty2
-      ]
-  prettyPrec _ (LambdaArgMismatch (getJoin -> (ty1, ty2))) =
-    "Lambda argument has type annotation" <+> bquote (ppr ty2) <> ", but expected argument type" <+> bquote (ppr ty1)
-  prettyPrec _ (FieldsMismatch (getJoin -> (expFs, actFs))) = fieldMismatchMsg expFs actFs
-  prettyPrec _ (EscapedSkolem x) =
-    "Skolem variable" <+> pretty x <+> "would escape its scope"
-  prettyPrec _ (UnboundVar x) =
-    "Unbound variable" <+> pretty x
-  prettyPrec _ (Infinite x uty) =
-    "Infinite type:" <+> ppr x <+> "=" <+> ppr uty
-  prettyPrec _ (DefNotTopLevel t) =
-    "Definitions may only be at the top level:" <+> ppr t
-  prettyPrec _ (CantInfer t) =
-    "Couldn't infer the type of term (this shouldn't happen; please report this as a bug!):" <+> ppr t
-  prettyPrec _ (CantInferProj t) =
-    "Can't infer the type of a record projection:" <+> ppr t
-  prettyPrec _ (UnknownProj x t) =
-    "Record does not have a field with name" <+> pretty x <> ":" <+> ppr t
-  prettyPrec _ (InvalidAtomic reason t) =
-    "Invalid atomic block:" <+> ppr reason <> ":" <+> ppr t
-  prettyPrec _ Impredicative =
-    "Unconstrained unification type variables encountered, likely due to an impredicative type. This is a known bug; for more information see https://github.com/swarm-game/swarm/issues/351 ."
+  prettyPrec _ = \case
+    UnifyErr ty1 ty2 ->
+      "Can't unify" <+> ppr ty1 <+> "and" <+> ppr ty2
+    Mismatch Nothing (getJoin -> (ty1, ty2)) ->
+      "Type mismatch: expected" <+> ppr ty1 <> ", but got" <+> ppr ty2
+    Mismatch (Just t) (getJoin -> (ty1, ty2)) ->
+      nest 2 . vcat $
+        [ "Type mismatch:"
+        , "From context, expected" <+> pprCode t <+> "to" <+> typeDescription Expected ty1 <> ","
+        , "but it" <+> typeDescription Actual ty2
+        ]
+    LambdaArgMismatch (getJoin -> (ty1, ty2)) ->
+      "Lambda argument has type annotation" <+> pprCode ty2 <> ", but expected argument type" <+> pprCode ty1
+    FieldsMismatch (getJoin -> (expFs, actFs)) ->
+      fieldMismatchMsg expFs actFs
+    EscapedSkolem x ->
+      "Skolem variable" <+> pretty x <+> "would escape its scope"
+    UnboundVar x ->
+      "Unbound variable" <+> pretty x
+    Infinite x uty ->
+      "Infinite type:" <+> ppr x <+> "=" <+> ppr uty
+    DefNotTopLevel t ->
+      "Definitions may only be at the top level:" <+> pprCode t
+    CantInfer t ->
+      "Couldn't infer the type of term (this shouldn't happen; please report this as a bug!):" <+> pprCode t
+    CantInferProj t ->
+      "Can't infer the type of a record projection:" <+> pprCode t
+    UnknownProj x t ->
+      "Record does not have a field with name" <+> pretty x <> ":" <+> pprCode t
+    InvalidAtomic reason t ->
+      "Invalid atomic block:" <+> ppr reason <> ":" <+> pprCode t
+    Impredicative ->
+      "Unconstrained unification type variables encountered, likely due to an impredicative type. This is a known bug; for more information see https://github.com/swarm-game/swarm/issues/351 ."
+   where
+    pprCode :: PrettyPrec a => a -> Doc ann
+    pprCode = bquote . ppr
 
 -- | Given a type and its source, construct an appropriate description
 --   of it to go in a type mismatch error message.

src/Swarm/Language/Text/Markdown.hs

@@ -53,10 +53,12 @@ import Data.Tuple.Extra (both, first)
 import Data.Vector (toList)
 import Data.Yaml
 import GHC.Exts qualified (IsList (..), IsString (..))
+import Prettyprinter (LayoutOptions (..), PageWidth (..), group, layoutPretty)
+import Prettyprinter.Render.Text qualified as RT
 import Swarm.Language.Module (moduleAST)
 import Swarm.Language.Parse (readTerm)
 import Swarm.Language.Pipeline (ProcessedTerm (..), processParsedTerm)
-import Swarm.Language.Pretty (PrettyPrec (..), prettyText, prettyTypeErrText)
+import Swarm.Language.Pretty (PrettyPrec (..), ppr, prettyText, prettyTypeErrText)
 import Swarm.Language.Syntax (Syntax)
 
 -- | The top-level markdown document.
@@ -309,9 +311,11 @@ class ToStream a where
 instance PrettyPrec a => ToStream (Node a) where
   toStream = \case
     LeafText a t -> [TextNode a t]
-    LeafCode t -> [CodeNode (prettyText t)]
+    LeafCode t -> [CodeNode (pprOneLine t)]
     LeafRaw s t -> [RawNode s t]
     LeafCodeBlock _i t -> [CodeNode (prettyText t)]
+   where
+    pprOneLine = RT.renderStrict . layoutPretty (LayoutOptions Unbounded) . group . ppr
 
 instance PrettyPrec a => ToStream (Paragraph a) where
   toStream = concatMap toStream . nodes

test/unit/TestLanguagePipeline.hs

@@ -180,19 +180,19 @@ testLanguagePipeline =
             "atomic move+move"
             ( process
                 "atomic (move; move)"
-                "1:8: Invalid atomic block: block could take too many ticks (2): move; move"
+                "1:8: Invalid atomic block: block could take too many ticks (2): `move; move`"
             )
         , testCase
             "atomic lambda"
             ( process
                 "atomic ((\\c. c;c) move)"
-                "1:9: Invalid atomic block: def, let, and lambda are not allowed: \\c. c; c"
+                "1:9: Invalid atomic block: def, let, and lambda are not allowed: `\\c. c; c`"
             )
         , testCase
             "atomic non-simple"
             ( process
                 "def dup = \\c. c; c end; atomic (dup (dup move))"
-                "1:33: Invalid atomic block: reference to variable with non-simple type ∀ a. cmd a -> cmd a: dup"
+                "1:33: Invalid atomic block: reference to variable with non-simple type ∀ a. cmd a -> cmd a: `dup`"
             )
         , testCase
             "atomic nested"
@@ -204,25 +204,25 @@ testLanguagePipeline =
             "atomic wait"
             ( process
                 "atomic (wait 1)"
-                "1:9: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: wait"
+                "1:9: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: `wait`"
             )
         , testCase
             "atomic make"
             ( process
                 "atomic (make \"PhD thesis\")"
-                "1:9: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: make"
+                "1:9: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: `make`"
             )
         , testCase
             "atomic drill"
             ( process
                 "atomic (drill forward)"
-                "1:9: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: drill"
+                "1:9: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: `drill`"
             )
         , testCase
             "atomic salvage"
             ( process
                 "atomic (salvage)"
-                "1:8: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: salvage"
+                "1:8: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: `salvage`"
             )
         ]
     , testGroup
@@ -396,7 +396,9 @@ testLanguagePipeline =
   process code expect = case processTerm code of
     Left e
       | not (T.null expect) && expect `T.isPrefixOf` e -> pure ()
-      | otherwise -> error $ "Unexpected failure: " <> show e
+      | otherwise ->
+          error $
+            "Unexpected failure:\n\n  " <> show e <> "\n\nExpected:\n\n  " <> show expect <> "\n"
     Right _
       | expect == "" -> pure ()
       | otherwise -> error "Unexpected success"