From c013035701578cca997abcd2a2c5b7cfd7bcac4f Mon Sep 17 00:00:00 2001
From: Brian Huffman <huffman@galois.com>
Date: Mon, 27 Sep 2021 10:05:24 -0700
Subject: [PATCH] Tweaks to line breaking in pretty printer.

Fixes #1289.
---
 src/Cryptol/Parser/AST.hs     | 10 +++++-----
 src/Cryptol/TypeCheck/Type.hs |  2 +-
 src/Cryptol/Utils/PP.hs       |  7 +++++--
 3 files changed, 11 insertions(+), 8 deletions(-)

diff --git a/src/Cryptol/Parser/AST.hs b/src/Cryptol/Parser/AST.hs
index 41acb6987..efc898a5d 100644
--- a/src/Cryptol/Parser/AST.hs
+++ b/src/Cryptol/Parser/AST.hs
@@ -642,7 +642,7 @@ instance (Show name, PPName name) => PP (Decl name) where
   ppPrec n decl =
     case decl of
       DSignature xs s -> commaSep (map ppL xs) <+> text ":" <+> pp s
-      DPatBind p e    -> pp p <+> text "=" <+> pp e
+      DPatBind p e    -> nest 2 (pp p <+> text "=" </> pp e)
       DBind b         -> ppPrec n b
       DRec bs         -> nest 2 (vcat ("recursive" : map (ppPrec n) bs))
       DFixity f ns    -> ppFixity f ns
@@ -695,7 +695,7 @@ ppPragma xs p =
 
 instance (Show name, PPName name) => PP (Bind name) where
   ppPrec _ b = vcat (sig ++ [ ppPragma [f] p | p <- bPragmas b ] ++
-                     [hang (def <+> eq) 4 (pp (thing (bDef b)))])
+                     [nest 2 (def <+> eq </> pp (thing (bDef b)))])
     where def | bInfix b  = lhsOp
               | otherwise = lhs
           f = bName b
@@ -850,7 +850,7 @@ instance (Show name, PPName name) => PP (Expr name) where
 
       -- low prec
       EFun _ xs e   -> wrap n 0 ((text "\\" <.> hsep (map (ppPrec 3) xs)) <+>
-                                 text "->" <+> pp e)
+                                 text "->" </> pp e)
 
       EIf e1 e2 e3  -> wrap n 0 $ sep [ text "if"   <+> pp e1
                                       , text "then" <+> pp e2
@@ -869,7 +869,7 @@ instance (Show name, PPName name) => PP (Expr name) where
               $ ppInfix 2 isInfix ifix
 
       EApp _ _      -> let (e, es) = asEApps expr in
-                       wrap n 3 (ppPrec 3 e <+> fsep (map (ppPrec 4) es))
+                       nest 2 (wrap n 3 (foldl (</>) (ppPrec 3 e) (map (ppPrec 4) es)))
 
       ELocated e _  -> ppPrec n e
 
@@ -959,7 +959,7 @@ instance PPName name => PP (Type name) where
                       $ ppPrefixName f <+> fsep (map (ppPrec 4) ts)
 
       TFun t1 t2     -> optParens (n > 1)
-                      $ sep [ppPrec 2 t1 <+> text "->", ppPrec 1 t2]
+                      $ ppPrec 2 t1 <+> text "->" </> ppPrec 1 t2
 
       TLocated t _   -> ppPrec n t
 
diff --git a/src/Cryptol/TypeCheck/Type.hs b/src/Cryptol/TypeCheck/Type.hs
index 4feba0af7..d4c4a911a 100644
--- a/src/Cryptol/TypeCheck/Type.hs
+++ b/src/Cryptol/TypeCheck/Type.hs
@@ -1020,7 +1020,7 @@ instance PP (WithNames Type) where
                               $ brackets (go 0 t1) <.> go 4 t2
 
           (TCFun,   [t1,t2])  -> optParens (prec > 1)
-                              $ go 2 t1 <+> text "->" <+> go 1 t2
+                              $ go 2 t1 <+> text "->" </> go 1 t2
 
           (TCTuple _, fs)     -> ppTuple $ map (go 0) fs
 
diff --git a/src/Cryptol/Utils/PP.hs b/src/Cryptol/Utils/PP.hs
index 7c14a3075..64c0183d3 100644
--- a/src/Cryptol/Utils/PP.hs
+++ b/src/Cryptol/Utils/PP.hs
@@ -240,7 +240,7 @@ infixl 6 <.>, <+>, </>
 (<+>)  = liftPP2 (PP.<+>)
 
 (</>) :: Doc -> Doc -> Doc
-Doc x </> Doc y = Doc (\e -> x e <> PP.softline <> y e)
+Doc x </> Doc y = Doc (\e -> x e <> PP.group (PP.line <> y e))
 
 infixl 5 $$
 
@@ -251,7 +251,10 @@ sep :: [Doc] -> Doc
 sep  = liftSep PP.sep
 
 fsep :: [Doc] -> Doc
-fsep  = liftSep PP.fillSep
+fsep  = liftSep fillSep
+  where
+    fillSep [] = mempty
+    fillSep (d0 : ds) = foldl (\a d -> a <> PP.group (PP.line <> d)) d0 ds
 
 hsep :: [Doc] -> Doc
 hsep  = liftSep PP.hsep