Make use of OpTree for type (signature) layouting, Fix layout

Some more cases that still produced broken layout on interaction
with do-blocks were fixed.

data/11-extensions/implicitparams.blt

@@ -8,9 +8,9 @@ func :: (?asd::Int) -> ()
 #test ImplicitParams 2
 {-# LANGUAGE ImplicitParams #-}
 func
-  :: (  ?asd
+  :: ( ?asd
-     :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+       :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
-     -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+       -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
      )
   -> ()
 

data/15-regressions.blt

@@ -964,7 +964,7 @@ func =
   Text.intercalate
     "\n"
     (   (\(abc, def) ->
-           abc ++ def ++ "lkajsdljkasdlkjasldjkljkasd" ++ asdasdasdasd
+          abc ++ def ++ "lkajsdljkasdlkjasldjkljkasd" ++ asdasdasdasd
         )
     <$> mylist
     )
@@ -1051,3 +1051,11 @@ func = do
      block comment -}
   x <- readLine
   print x
+
+#test broken layout on do + operator + paren + do
+func = do
+  (wrapper $ do
+    stmt1
+    stmt2
+    )
+    `shouldReturn` thing

data/30-tests-context-free.blt

@@ -270,8 +270,8 @@ func :: (?asd::Int) -> ()
 {-# LANGUAGE ImplicitParams #-}
 func
   :: ( ?asd
-     :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+       :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
-     -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+       -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
      )
   -> ()
 

source/library/Language/Haskell/Brittany/Internal/Components/OpTree.hs

@@ -32,8 +32,8 @@ displayOpTree = \case
     ++ " ["
     ++ intercalate
          ","
-         [ ("(" ++ showOp op ++ "," ++ show x ++ ")") | (op, (x, _)) <- rs ]
+         [ ("(" ++ showOp op ++ "," ++ displayOpTree x ++ ")") | (op, x) <- rs ]
-    ++ "]"
+    ++ "])"
     )
   OpKnown p _ _ fixity tree ops ->
     (  "OpKnown "
@@ -89,7 +89,20 @@ type Stack = [StackElem]
 
 balanceOpTree :: Bool -> OpTree -> ([BrittanyError], OpTree)
 balanceOpTree allowUnqualify = \case
-  x@OpLeaf{}  -> ([], x)
+  x@OpLeaf{} -> ([], x)
+  OpKnown paren locO locC fixity@(Fixity _ (-1) _) left rest ->
+    let
+        (warnsLeft, balancedLeft) = balanceOpTree allowUnqualify left
+        opRes =
+          [ (op, balanceOpTree allowUnqualify argTree) | (op, argTree) <- rest ]
+    in  ( warnsLeft ++ [ w | (_, (warns, _)) <- opRes, w <- warns ]
+        , OpKnown paren
+                  locO
+                  locC
+                  fixity
+                  balancedLeft
+                  [ (op, balanced) | (op, (_, balanced)) <- opRes ]
+        )
   x@OpKnown{} -> ([], x)
   x@(OpUnknown paren locO locC left rest) ->
     let (warns, balancedLeft) = balanceOpTree allowUnqualify left
@@ -109,11 +122,7 @@ balanceOpTree allowUnqualify = \case
  where
   -- singleton :: BriDocNumbered -> StackElem
   -- singleton x = StackElem (Fixity NoSourceText 99 InfixN) (OpLeaf x) []
-  go
+  go :: Stack -> [(BriDocNumbered, OpTree)] -> OpTree -> Either [String] OpTree
-    :: Stack
-    -> [(BriDocNumbered, BriDocNumbered)]
-    -> OpTree
-    -> Either [String] OpTree
   go [] [] _ = Left []
   go [StackElem fxty cs] [] c =
     let (e1, eops) = shiftOps cs c in Right (known fxty e1 eops)
@@ -124,24 +133,20 @@ balanceOpTree allowUnqualify = \case
   go stack input@((opDoc, val) : inputR) c = case stack of
     [] -> do
       fxty <- docFixity opDoc
-      go [StackElem fxty [(c, opDoc)]] inputR (OpLeaf val)
+      go [StackElem fxty [(c, opDoc)]] inputR val
     (StackElem fixityS cs : stackR) -> do
       let Fixity _ precS dirS = fixityS
       fxty@(Fixity _ prec dir) <- docFixity opDoc
       case compare prec precS of
-        GT -> go (StackElem fxty [(c, opDoc)] : stack) inputR (OpLeaf val)
+        GT -> go (StackElem fxty [(c, opDoc)] : stack) inputR val
         LT -> do
           let (e1, eops) = shiftOps cs c
           go stackR input (known fixityS e1 eops)
         EQ -> case (dir, dirS) of
           (InfixR, InfixR) ->
-            go (StackElem fixityS ((c, opDoc) : cs) : stackR)
+            go (StackElem fixityS ((c, opDoc) : cs) : stackR) inputR val
-               inputR
-               (OpLeaf val)
           (InfixL, InfixL) ->
-            go (StackElem fixityS ((c, opDoc) : cs) : stackR)
+            go (StackElem fixityS ((c, opDoc) : cs) : stackR) inputR val
-               inputR
-               (OpLeaf val)
           _ -> Left []
   docFixity :: BriDocNumbered -> Either [String] Fixity
   docFixity (_, x) = case x of
@@ -163,9 +168,9 @@ balanceOpTree allowUnqualify = \case
               mapAccumL (\op (nextE, nextOp) -> (nextOp, (op, nextE))) o1 rest
         in  list ++ [(finalOp, final)]
       )
-  known = OpKnown False Nothing Nothing
+  known = OpKnown NoParen Nothing Nothing
 
-addAllParens :: Bool -> OpTree -> OpTree
+addAllParens :: OpParenMode -> OpTree -> OpTree
 addAllParens topLevelParen = \case
   x@OpLeaf{}    -> x
   x@OpUnknown{} -> x
@@ -174,8 +179,8 @@ addAllParens topLevelParen = \case
             locO
             locC
             fixity
-            (addAllParens True c)
+            (addAllParens ParenWithSpace c)
-            [ (op, addAllParens True tree) | (op, tree) <- cs ]
+            [ (op, addAllParens ParenWithSpace tree) | (op, tree) <- cs ]
 
 remSuperfluousParens :: Int -> OpTree -> OpTree
 remSuperfluousParens outerFixity = \case
@@ -183,7 +188,12 @@ remSuperfluousParens outerFixity = \case
   x@OpUnknown{} -> x
   OpKnown paren locO locC fixity c cs ->
     OpKnown
-      (paren && outerFixity > fixLevel fixity)
+      -- We do not support removing superfluous parens around
+      -- function types yet:
+      (if outerFixity > fixLevel fixity || fixLevel fixity < 0
+        then paren
+        else NoParen
+      )
       locO
       locC
       fixity
@@ -193,6 +203,8 @@ remSuperfluousParens outerFixity = \case
 
 hardcodedFixity :: Bool -> String -> Maybe Fixity
 hardcodedFixity allowUnqualify = \case
+  --
+  "->"          -> Just $ Fixity NoSourceText (-1) InfixR
   "."           -> Just $ Fixity NoSourceText 9 InfixR
   "!!"          -> Just $ Fixity NoSourceText 9 InfixL
   "**"          -> Just $ Fixity NoSourceText 8 InfixR

source/library/Language/Haskell/Brittany/Internal/ToBriDoc/DataDecl.hs

@@ -293,9 +293,9 @@ layoutConDecl (prefix, L _ con) = case con of
 layoutHsTyPats
   :: [LHsTypeArg GhcPs] -> [ToBriDocM BriDocNumbered]
 layoutHsTyPats pats = pats <&> \case
-  HsValArg tm -> callLayouter layout_type tm
+  HsValArg tm -> callLayouter2 layout_type False tm
   HsTypeArg _l ty ->
-    docSeq [docLit $ Text.pack "@", callLayouter layout_type ty]
+    docSeq [docLit $ Text.pack "@", callLayouter2 layout_type False ty]
     -- we ignore the SourceLoc here.. this LPat not being (L _ Pat{}) change
     -- is a bit strange. Hopefully this does not ignore any important
     -- annotations.
@@ -304,10 +304,10 @@ layoutHsTyPats pats = pats <&> \case
 createContextDoc :: HsContext GhcPs -> ToBriDocM BriDocNumbered
 createContextDoc [] = docEmpty
 createContextDoc [t] =
-  docSeq [callLayouter layout_type t, docSeparator, docLitS "=>", docSeparator]
+  docSeq [callLayouter2 layout_type False t, docSeparator, docLitS "=>", docSeparator]
 createContextDoc (t1 : tR) = do
-  t1Doc <- shareDoc $ callLayouter layout_type t1
+  t1Doc <- shareDoc $ callLayouter2 layout_type False t1
-  tRDocs <- tR `forM` (shareDoc . callLayouter layout_type)
+  tRDocs <- tR `forM` (shareDoc . callLayouter2 layout_type False)
   docAlt
     [ docSeq
       [ docLitS "("
@@ -329,7 +329,7 @@ createBndrDoc = map $ \x -> do
   (vname, mKind) <- case x of
     (L _ (UserTyVar _ _ext vname)) -> return $ (lrdrNameToText vname, Nothing)
     (L _ (KindedTyVar _ _ext lrdrName kind)) -> do
-      d <- shareDoc $ callLayouter layout_type kind
+      d <- shareDoc $ callLayouter2 layout_type False kind
       return $ (lrdrNameToText lrdrName, Just $ d)
   case mKind of
     Nothing -> docLit vname
@@ -423,25 +423,25 @@ createDetailsDoc consNameStr details = case details of
         $ docSeq
         $ List.intersperse docSeparator
         $ fmap hsScaledThing args
-        <&> callLayouter layout_type
+        <&> callLayouter2 layout_type False
         ]
       leftIndented =
         docSetParSpacing
           . docAddBaseY BrIndentRegular
           . docPar (docLit consNameStr)
           . docLines
-          $ callLayouter layout_type
+          $ callLayouter2 layout_type False
           <$> fmap hsScaledThing args
       multiAppended = docSeq
         [ docLit consNameStr
         , docSeparator
         , docSetBaseY
           $ docLines
-          $ callLayouter layout_type <$> fmap hsScaledThing args
+          $ callLayouter2 layout_type False <$> fmap hsScaledThing args
         ]
       multiIndented = docSetBaseY $ docAddBaseY BrIndentRegular $ docPar
         (docLit consNameStr)
-        (docLines $ callLayouter layout_type <$> fmap hsScaledThing args)
+        (docLines $ callLayouter2 layout_type False <$> fmap hsScaledThing args)
     case indentPolicy of
       IndentPolicyLeft -> docAlt [singleLine, leftIndented]
       IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented]
@@ -521,11 +521,11 @@ createDetailsDoc consNameStr details = case details of
           ]
         )
   InfixCon arg1 arg2 -> docSeq
-    [ callLayouter layout_type $ hsScaledThing arg1
+    [ callLayouter2 layout_type False $ hsScaledThing arg1
     , docSeparator
     , docLit consNameStr
     , docSeparator
-    , callLayouter layout_type $ hsScaledThing arg2
+    , callLayouter2 layout_type False $ hsScaledThing arg2
     ]
  where
   mkFieldDocs
@@ -551,7 +551,10 @@ createNamesAndTypeDoc lField@(L _ (ConDeclField epAnn names t _)) =
             L _ (FieldOcc _ fieldName) ->
               docLit =<< lrdrNameToTextAnn fieldName
         ]
-  , docFlushCommsPost True posComma (callLayouter layout_type t)
+  , docFlushCommsPost
+      True
+      posComma
+      (callLayouter2 layout_type (hasAnyCommentsBelow epAnn) t)
   )
  where
   (posStart, posComma) = obtainListElemStartCommaLocs lField

source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs

@@ -806,7 +806,7 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of
                  ]
               ++ fmap (layoutTyVarBndr True) (hsq_explicit vars)
       sharedLhs <- shareDoc $ id lhs
-      typeDoc   <- shareDoc $ callLayouter layout_type typ
+      typeDoc   <- shareDoc $ callLayouter2 layout_type False typ
       let hasComments = hasAnyCommentsConnected ltycl
       layoutLhsAndType hasComments
                        sharedLhs
@@ -830,7 +830,7 @@ layoutTyVarBndr needsSep (L _ bndr) = case bndr of
       ++ [ docLit $ Text.pack "("
          , appSep $ docLit nameStr
          , appSep . docLit $ Text.pack "::"
-         , docForceSingleline $ callLayouter layout_type kind
+         , docForceSingleline $ callLayouter2 layout_type False kind
          , docLit $ Text.pack ")"
          ]
 
@@ -883,7 +883,7 @@ layoutTyFamInstDecl inClass outerNode tfid = do
     -- <$> hasAnyRegularCommentsConnected outerNode
     -- <*> hasAnyRegularCommentsRest innerNode
   let hasComments = hasAnyCommentsConnected outerNode
-  typeDoc <- shareDoc $ callLayouter layout_type typ
+  typeDoc <- shareDoc $ callLayouter2 layout_type False typ
   layoutLhsAndType hasComments lhs (docHandleComms posEqual $ docLit $ Text.pack "=") 1 typeDoc
 
 

source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs

@@ -214,7 +214,7 @@ layoutExpr lexpr@(L _ expr) = do
           headDoc
           (docNonBottomSpacing $ docLines paramDocs)
     HsAppType _ exp1 (HsWC _ ty1) -> do
-      t <- shareDoc $ callLayouter layout_type ty1
+      t <- shareDoc $ callLayouter2 layout_type False ty1
       e <- shareDoc $ callLayouter layout_expr exp1
       docAlt
         [ docSeq
@@ -238,52 +238,16 @@ layoutExpr lexpr@(L _ expr) = do
       --         || hasAnyCommentsConnected expOp
       layouters <- mAsk
       treeAndHasComms <-
-        layout_gatherOpTreeE layouters False False id Nothing Nothing [] lexpr
+        layout_gatherOpTreeE layouters NoParen False id Nothing Nothing [] lexpr
       layout_opTree layouters treeAndHasComms
     NegApp _ op _ -> do
       opDoc <- shareDoc $ layoutExpr op
       docSeq [docLit $ Text.pack "-", opDoc]
-    HsPar _epAnn (L _ (OpApp _topEpAnn _expLeft _expOp _)) -> do
+    HsPar _epAnn _inner -> do
-      -- let innerHasComments =
-      --       not
-      --         $  hasAnyCommentsConnected expLeft
-      --         || hasAnyCommentsConnected expOp
-      -- let AnnParen _ spanOpen spanClose = anns epAnn
-      -- docHandleComms epAnn
-      --   $ processOpTree
-      --     lop
-      --     innerHasComments
-      --     True
-      --     (Just $ epaLocationRealSrcSpanStart spanOpen)
-      --     (Just $ epaLocationRealSrcSpanStart spanClose)
-      -- let hasComments = hasAnyCommentsConnected lexpr
-                  -- not
-                  --   $  hasAnyCommentsConnected expLeft
-                  --   || hasAnyCommentsConnected expOp
       layouters <- mAsk
       treeAndHasComms <-
-        layout_gatherOpTreeE layouters False False id Nothing Nothing [] lexpr
+        layout_gatherOpTreeE layouters NoParen False id Nothing Nothing [] lexpr
       layout_opTree layouters treeAndHasComms
-    HsPar epAnn innerExp -> docHandleComms epAnn $ do
-      let AnnParen _ spanOpen spanClose = anns epAnn
-      let wrapOpen                      = docHandleComms spanOpen
-      let wrapClose                     = docHandleComms spanClose
-      innerExpDoc <- shareDoc $ layoutExpr innerExp
-      docAlt
-        [ docSeq
-          [ wrapOpen $ docLit $ Text.pack "("
-          , docForceSingleline innerExpDoc
-          , wrapClose $ docLit $ Text.pack ")"
-          ]
-        , docSetBaseY $ docLines
-          [ docCols
-            ColOpPrefix
-            [ wrapOpen $ docLit $ Text.pack "("
-            , docAddBaseY (BrIndentSpecial 2) innerExpDoc
-            ]
-          , wrapClose $ docLit $ Text.pack ")"
-          ]
-        ]
     SectionL _ left op -> do -- TODO: add to testsuite
       leftDoc <- shareDoc $ layoutExpr left
       opDoc   <- shareDoc $ layoutExpr op

source/library/Language/Haskell/Brittany/Internal/ToBriDoc/OpTree.hs

@@ -18,124 +18,136 @@ import           Language.Haskell.Brittany.Internal.Utils
 
 
 gatherOpTreeE
-  :: Bool
+  :: OpParenMode
   -> Bool
   -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered)
   -> Maybe GHC.RealSrcLoc
   -> Maybe GHC.RealSrcLoc
-  -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)]
+  -> [(ToBriDocM BriDocNumbered, OpTree)]
   -> LHsExpr GhcPs
   -> ToBriDocM (OpTree, Bool)
 gatherOpTreeE hasParen hasComms commWrap locOpen locClose opExprList = \case
-  (L _ (OpApp epAnn l1 op1 r1)) ->
+  (L _ (OpApp epAnn l1 op1 r1)) -> do
+    inner <- callLayouter layout_expr r1
     gatherOpTreeE
-      hasParen
+      (case hasParen of
+        NoParen -> NoParen
+        _       -> ParenWithSpace
+      )
       (hasComms || hasAnyCommentsBelow epAnn)
       commWrap
       locOpen
       locClose
       ( ( docHandleComms epAnn $ callLayouter layout_expr op1
-        , callLayouter layout_expr r1
+        , OpLeaf inner
         )
       : opExprList
       )
       l1
+  (L _ (HsPar epAnn inner)) | hasParen == NoParen && null opExprList -> do
+    let AnnParen _ spanOpen spanClose = anns epAnn
+    let mergePoses locMay span = case locMay of
+          Nothing  -> Just (epaLocationRealSrcSpanStart span)
+          Just loc -> Just (min (epaLocationRealSrcSpanStart span) loc)
+    gatherOpTreeE ParenNoSpace
+                  (hasComms || hasAnyCommentsBelow epAnn)
+                  (commWrap . docHandleComms epAnn)
+                  (mergePoses locOpen spanOpen)
+                  (mergePoses locClose spanClose)
+                  []
+                  inner
   (L _ (HsPar epAnn inner)) -> do
     let AnnParen _ spanOpen spanClose = anns epAnn
     let mergePoses locMay span = case locMay of
           Nothing  -> Just (epaLocationRealSrcSpanStart span)
           Just loc -> Just (min (epaLocationRealSrcSpanStart span) loc)
     (innerTree, innerHasComms) <-
-      gatherOpTreeE True
+      gatherOpTreeE ParenNoSpace
                     (hasComms || hasAnyCommentsBelow epAnn)
                     (commWrap . docHandleComms epAnn)
                     (mergePoses locOpen spanOpen)
                     (mergePoses locClose spanClose)
                     []
                     inner
-    if null opExprList
+    -- if null opExprList
-      then pure (innerTree, innerHasComms)
+    --   then pure (innerTree, innerHasComms)
-      else do
+    --   else do
-        numberedRights <- opExprList `forM` \(x, y) -> do
+    numberedRights <-
-          x' <- x
+      opExprList
-          y' <- y
+      `forM` \(x, y) -> do
-          pure (x', y')
+               x' <- x
-        pure
+               pure (x', y)
-          $ ( OpUnknown hasParen locOpen locClose innerTree numberedRights
-            , innerHasComms
-            )
-  final -> do
-    numberedLeft   <- commWrap $ callLayouter layout_expr final
-    numberedRights <- opExprList `forM` \(x, y) -> do
-      x' <- x
-      y' <- y
-      pure (x', y')
     pure
-      $ ( OpUnknown hasParen
+      $ ( OpUnknown hasParen locOpen locClose innerTree numberedRights
-                    locOpen
+        , innerHasComms
-                    locClose
+        )
-                    (OpLeaf $ numberedLeft)
+  final | hasParen == NoParen && null opExprList -> do
-                    numberedRights
+    tree <- commWrap $ callLayouter layout_expr final
+    pure (OpLeaf tree, hasComms)
+  final@(L _ inner) -> do
+    numberedLeft   <- commWrap $ callLayouter layout_expr final
+    numberedRights <-
+      opExprList
+      `forM` \(x, y) -> do
+               x' <- x
+               pure (x', y)
+    pure
+      $ ( OpUnknown
+            (case (hasParen, inner) of
+              (NoParen, _              ) -> NoParen
+              (_      , ExplicitTuple{}) -> ParenWithSpace
+              _                          -> hasParen
+            )
+            locOpen
+            locClose
+            (OpLeaf $ numberedLeft)
+            numberedRights
         , hasComms
         )
 
 gatherOpTreeT
-  :: Bool
+  :: OpParenMode
   -> Bool
   -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered)
   -> Maybe GHC.RealSrcLoc
   -> Maybe GHC.RealSrcLoc
-  -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)]
+  -> [(ToBriDocM BriDocNumbered, OpTree)]
   -> LHsType GhcPs
   -> ToBriDocM (OpTree, Bool)
 gatherOpTreeT hasParen hasComms commWrap locOpen locClose opExprList = \case
-  (L _ (HsOpTy NoExtField l1 op1 r1)) ->
+  (L _ (HsOpTy NoExtField l1 op1 r1)) -> do
+    inner <- callLayouter2 layout_type False r1
     gatherOpTreeT
-      hasParen
+      (case hasParen of
+        NoParen -> NoParen
+        _       -> ParenWithSpace
+      )
       hasComms
       commWrap
       locOpen
       locClose
-      ( (docLit $ printRdrNameWithAnns op1, callLayouter layout_type r1)
+      ( (docLit $ printRdrNameWithAnns op1, OpLeaf inner)
       : opExprList
       )
       l1
-  (L _ (HsParTy epAnn inner)) -> do
+  final@(L _ inner) -> do
-    let AnnParen _ spanOpen spanClose = anns epAnn
+    numberedLeft   <- commWrap $ callLayouter2 layout_type False final
-    let mergePoses locMay span = case locMay of
+    numberedRights <-
-          Nothing  -> Just (epaLocationRealSrcSpanStart span)
+      opExprList
-          Just loc -> Just (min (epaLocationRealSrcSpanStart span) loc)
+      `forM` \(x, y) -> do
-    (innerTree, innerHasComms) <-
+               x' <- x
-      gatherOpTreeT True
+               pure (x', y)
-                    (hasComms || hasAnyCommentsBelow epAnn)
-                    (commWrap . docHandleComms epAnn)
-                    (mergePoses locOpen spanOpen)
-                    (mergePoses locClose spanClose)
-                    []
-                    inner
-    if null opExprList
-      then pure (innerTree, innerHasComms)
-      else do
-        numberedRights <- opExprList `forM` \(x, y) -> do
-          x' <- x
-          y' <- y
-          pure (x', y')
-        pure
-          $ ( OpUnknown hasParen locOpen locClose innerTree numberedRights
-            , innerHasComms
-            )
-  final -> do
-    numberedLeft   <- commWrap $ callLayouter layout_type final
-    numberedRights <- opExprList `forM` \(x, y) -> do
-      x' <- x
-      y' <- y
-      pure (x', y')
     pure
-      $ ( OpUnknown hasParen
+      $ ( OpUnknown
-                    locOpen
+            (case (hasParen, inner) of
-                    locClose
+              (NoParen, _          ) -> NoParen
-                    (OpLeaf $ numberedLeft)
+              (_      , HsTupleTy{}) -> ParenWithSpace
-                    numberedRights
+              _                      -> hasParen
+            )
+            locOpen
+            locClose
+            (OpLeaf $ numberedLeft)
+            numberedRights
         , hasComms
         )
 
@@ -151,7 +163,8 @@ processOpTree (unknownTree, hasComments) = do
   let processedTree = case refactorMode of
         PRMKeep     -> balancedTree
         PRMMinimize -> remSuperfluousParens 11 balancedTree
-        PRMMaximize -> addAllParens False balancedTree
+        PRMMaximize -> addAllParens NoParen balancedTree
+  -- tellDebugMess $ displayOpTree unknownTree
   -- tellDebugMess $ displayOpTree balancedTree
   -- tellDebugMess $ displayOpTree processedTree
   layoutOpTree (not hasComments) processedTree
@@ -159,19 +172,44 @@ processOpTree (unknownTree, hasComments) = do
 layoutOpTree :: Bool -> OpTree -> ToBriDocM BriDocNumbered
 layoutOpTree allowSinglelinePar = \case
   OpUnknown hasParen locO locC leftTree docOps -> do
-    let sharedOps = fmap (\(a, b) -> (pure a, pure b)) docOps
+    let sharedOps = fmap (\(a, b) -> (pure a, layoutOpTree True b)) docOps
-    leftDoc <- layoutOpTree True leftTree
     coreAlternative hasParen
                     locO
                     locC
                     Nothing
-                    (pure leftDoc)
+                    leftTree
                     sharedOps
                     sharedOps
                     docForceSingleline
+  OpKnown NoParen Nothing Nothing fixity treeL docOps
+    | Fixity _ (-1) _ <- fixity -> do
+      dHead <- shareDoc $ layoutOpTree True treeL
+      body  <- forM docOps $ \(op, arg) -> do
+        arg' <- shareDoc $ layoutOpTree True arg
+        pure (op, arg')
+      runFilteredAlternative $ do
+        addAlternativeCond allowSinglelinePar
+          $ docForceSingleline
+          $ docSeq
+          $ dHead
+          : join
+              [ [docSeparator, pure prefix, docSeparator, doc]
+              | (prefix, doc) <- body
+              ]
+        addAlternative $ docPar (docSetBaseY dHead) $ docLines
+          [ docCols
+              ColTyOpPrefix
+              [ appSep $ case prefix of
+                (_, BDLit s) | Text.length s == 1 -> docSeq
+                  [docLitS " ", pure prefix]
+                _ -> pure prefix
+              , docEnsureIndent (BrIndentSpecial (length prefix + 1))
+              $ docSetBaseY doc
+              ]
+          | (prefix, doc) <- body
+          ]
   OpKnown hasParen locO locC fixity treeL docOps -> do
     let Fixity _ _prec _ = fixity
-    docL <- shareDoc $ layoutOpTree True treeL
     let flattenList ops = case ops of
           []           -> pure []
           [(op, tree)] -> case treeL of
@@ -185,7 +223,7 @@ layoutOpTree allowSinglelinePar = \case
             pure $ (pure op1, tree1Doc) : flattenRest
           _ -> simpleTransform ops
         flattenInner op = \case
-          OpKnown False _ _ _ innerL innerOps | isPrec0 fixity -> do
+          OpKnown NoParen _ _ _ innerL innerOps | isPrec0 fixity -> do
             flattenList ((op, innerL) : innerOps)
           tree -> do
             treeDoc <- shareDoc $ layoutOpTree True tree
@@ -205,7 +243,7 @@ layoutOpTree allowSinglelinePar = \case
                     locO
                     locC
                     (Just fixity)
-                    docL
+                    treeL
                     sharedOps
                     sharedOpsFlat
                     lastWrap
@@ -215,22 +253,74 @@ layoutOpTree allowSinglelinePar = \case
   getPrec = \case
     Fixity _ prec _ -> prec
   coreAlternative
-    :: Bool
+    :: OpParenMode
     -> Maybe GHC.RealSrcLoc
     -> Maybe GHC.RealSrcLoc
     -> Maybe Fixity
-    -> ToBriDocM BriDocNumbered
+    -> OpTree
     -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)]
     -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)]
     -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered)
     -> ToBriDocM BriDocNumbered
-  coreAlternative hasParen locO locC fixity docL sharedOps sharedOpsFlat lastWrap
+  coreAlternative NoParen _loc0 _locC _fixity treeL [] [] _lastWrap = do
+    layoutOpTree True treeL
+  coreAlternative ParenNoSpace locO locC _fixity treeL [] [] _lastWrap = do
+    docL <- shareDoc $ layoutOpTree True treeL
+    docAlt
+      [ docSeq
+        [ docLitS "("
+        , docHandleComms locO $ docForceSingleline docL
+        , docHandleComms locC $ docLitS ")"
+        ]
+      , docForceZeroAdd $ docSetBaseY $ docLines
+        [ docSeq
+          [ docLitS "("
+          , docHandleComms locO $ docAddBaseY (BrIndentSpecial 2) $ docL
+          ]
+        , docHandleComms locC $ docLitS ")"
+        ]
+      , docPar
+        (docSeq
+          [ docLitS "("
+          , docHandleComms locO $ docAddBaseY (BrIndentSpecial 2) $ docL
+          ]
+        )
+        (docHandleComms locC $ docLitS ")")
+      ]
+  coreAlternative ParenWithSpace locO locC _fixity treeL [] [] _lastWrap = do
+    docL <- shareDoc $ layoutOpTree True treeL
+    docAlt
+      [ docSeq
+        [ docLitS "("
+        , docHandleComms locO $ docForceSingleline docL
+        , docHandleComms locC $ docLitS ")"
+        ]
+      , docForceZeroAdd $ docSetBaseY $ docLines
+        [ docSeq
+          [ docLitS "("
+          , docSeparator
+          , docHandleComms locO $ docAddBaseY (BrIndentSpecial 2) $ docL
+          ]
+        , docHandleComms locC $ docLitS ")"
+        ]
+      , docPar
+        (docSeq
+          [ docLitS "("
+          , docSeparator
+          , docHandleComms locO $ docAddBaseY (BrIndentSpecial 2) $ docL
+          ]
+        )
+        (docHandleComms locC $ docLitS ")")
+      ]
+  coreAlternative hasParen locO locC fixity treeL sharedOps sharedOpsFlat lastWrap
     = do
+      docL <- shareDoc $ layoutOpTree True treeL
       indentPolicy <- askLayoutConf _lconfig_indentPolicy
-      let zeroOps = null sharedOps
+      let zeroOps       = null sharedOps
-          wrapParenIfSl x inner = if x
+          spaceAfterPar = not zeroOps
-            then wrapParenSl inner
+          wrapParenIfSl x inner = if x == NoParen
-            else docSetParSpacing inner
+            then docSetParSpacing inner
+            else wrapParenSl inner
           wrapParenSl inner = docAlt
             [ docSeq
               [ docLit $ Text.pack "("
@@ -242,24 +332,29 @@ layoutOpTree allowSinglelinePar = \case
               , docHandleComms locC $ docLit $ Text.pack ")"
               ]
             ]
-          wrapParenMlIf x innerHead innerLines = if x
+          wrapParenMlIf x innerHead innerLines = case x of
-            then wrapParenMl innerHead innerLines
+            NoParen        -> docPar innerHead (docLines innerLines)
-            else docPar innerHead (docLines innerLines)
+            ParenWithSpace -> wrapParenMl True innerHead innerLines
-          wrapParenMl innerHead innerLines = docAlt
+            ParenNoSpace   -> wrapParenMl False innerHead innerLines
+          wrapParenMl space innerHead innerLines = docAlt
             [ docForceZeroAdd $ docSetBaseY $ docLines
-              (  [ docCols
+              ( [ docCols
-                     ColOpPrefix
+                    ColOpPrefix
-                     [ (if zeroOps then id else appSep) $ docLit $ Text.pack "("
+                    [ (if spaceAfterPar || space then appSep else id)
-                     , docHandleComms locO $ innerHead
+                    $ docLit
-                     ]
+                    $ Text.pack "("
-                 ]
+                    , docHandleComms locO $ innerHead
+                    ]
+                ]
               ++ innerLines
               ++ [docHandleComms locC $ docLit $ Text.pack ")"]
               )
             , docPar
               (docCols
                 ColOpPrefix
-                [ (if zeroOps then id else appSep) $ docLit $ Text.pack "("
+                [ (if spaceAfterPar || space then appSep else id)
+                $ docLit
+                $ Text.pack "("
                 , docHandleComms locO $ innerHead
                 ]
               )
@@ -269,9 +364,12 @@ layoutOpTree allowSinglelinePar = \case
             ]
 
       configAllowsParInsert <- askLayoutConf _lconfig_fixityBasedAddAlignParens
-      let allowParIns = configAllowsParInsert && case fixity of
+      let allowParIns =
-            Nothing                -> False
+            (  configAllowsParInsert
-            Just (Fixity _ prec _) -> prec > 0
+            && case fixity of
+                 Nothing                -> False
+                 Just (Fixity _ prec _) -> prec > 0
+            )
 
       let isSingleOp = length sharedOps == 1 && length sharedOpsFlat == 1
 
@@ -284,39 +382,40 @@ layoutOpTree allowSinglelinePar = \case
           $ wrapParenIfSl hasParen
           $ docSetParSpacing
           $ docSeq
-              ([docForceSingleline docL] ++ case splitFirstLast sharedOpsFlat of
+              ( [docForceSingleline docL]
-                FirstLastEmpty -> []
+              ++ case splitFirstLast sharedOpsFlat of
-                FirstLastSingleton (od, ed) ->
+                   FirstLastEmpty -> []
-                  [ docSeparator
+                   FirstLastSingleton (od, ed) ->
-                  , docForceSingleline od
+                     [ docSeparator
-                  , docSeparator
+                     , docForceSingleline od
-                  , lastWrap ed
-                  ]
-                FirstLast (od1, ed1) ems (odN, edN) ->
-                  (  [ docSeparator
-                     , docForceSingleline od1
                      , docSeparator
-                     , docForceSingleline ed1
+                     , lastWrap ed
                      ]
-                  ++ join
+                   FirstLast (od1, ed1) ems (odN, edN) ->
-                       [ [ docSeparator
+                     (  [ docSeparator
-                         , docForceSingleline od
+                        , docForceSingleline od1
-                         , docSeparator
+                        , docSeparator
-                         , docForceSingleline ed
+                        , docForceSingleline ed1
-                         ]
+                        ]
-                       | (od, ed) <- ems
+                     ++ join
-                       ]
+                          [ [ docSeparator
-                  ++ [ docSeparator
+                            , docForceSingleline od
-                     , docForceSingleline odN
+                            , docSeparator
-                     , docSeparator
+                            , docForceSingleline ed
-                     , lastWrap edN
+                            ]
-                     ]
+                          | (od, ed) <- ems
-                  )
+                          ]
+                     ++ [ docSeparator
+                        , docForceSingleline odN
+                        , docSeparator
+                        , lastWrap edN
+                        ]
+                     )
               )
         -- one
         -- + two
         -- + three
-        addAlternativeCond (not hasParen && not isSingleOp) $ docPar
+        addAlternativeCond (hasParen == NoParen && not isSingleOp) $ docPar
           (docHandleComms locO $ docForceSingleline $ docL)
           (docFlushCommsPost False locC $ docLines $ sharedOps <&> \(od, ed) ->
             docCols ColOpPrefix [appSep od, docForceSingleline ed]
@@ -330,7 +429,7 @@ layoutOpTree allowSinglelinePar = \case
               Just (Fixity _ prec _) -> prec == 0
         case sharedOps of
           [(od, ed)] | curIsPrec0 ->
-            addAlternativeCond (not hasParen && isSingleOp)
+            addAlternativeCond (hasParen == NoParen && isSingleOp)
               $ docSetParSpacing
               $ docPar (docHandleComms locO $ docForceSingleline $ docL)
                        (docSeq [od, docSeparator, singlelineUnlessFree ed])
@@ -339,9 +438,10 @@ layoutOpTree allowSinglelinePar = \case
         -- > + two
         -- > + three
         -- > )
-        addAlternativeCond (allowParIns && not hasParen)
+        addAlternativeCond (allowParIns && hasParen == NoParen)
           $ docForceZeroAdd
           $ wrapParenMl
+              True
               (docSetBaseY docL)
               (sharedOps <&> \(od, ed) ->
                 docCols ColOpPrefix [appSep od, docSetBaseY ed]
@@ -353,7 +453,7 @@ layoutOpTree allowSinglelinePar = \case
           $ wrapParenMlIf
             hasParen
           -- ((if not hasParen then docAddBaseY BrIndentRegular else id) docL)
-            (if hasParen then docSetBaseY docL else docL)
+            (if hasParen /= NoParen then docSetBaseY docL else docL)
-            ((if hasParen then sharedOps else sharedOpsFlat) <&> \(od, ed) ->
+            ( (if hasParen /= NoParen then sharedOps else sharedOpsFlat)
-              docCols ColOpPrefix [appSep od, docSetBaseY ed]
+            <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]
             )

source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Pattern.hs

@@ -142,7 +142,7 @@ layoutPat lpat@(L _ pat) = docHandleComms lpat $ case pat of
   SigPat _ pat1 (HsPS _ ty1) -> do
     -- i :: Int -> expr
     patDocs <- layoutPat pat1
-    tyDoc <- shareDoc $ callLayouter layout_type ty1
+    tyDoc <- shareDoc $ callLayouter2 layout_type False ty1
     case Seq.viewr patDocs of
       Seq.EmptyR -> error "cannot happen ljoiuxoasdcoviuasd"
       xR Seq.:> xN -> do

source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs

@@ -11,6 +11,9 @@ import GHC.Types.SourceText(SourceText(SourceText, NoSourceText))
 import qualified GHC.OldList as List
 import GHC.Types.Basic
 import GHC.Utils.Outputable (ftext, showSDocUnsafe)
+import           GHC.Types.Fixity               ( Fixity(Fixity)
+                                                , FixityDirection(InfixN)
+                                                )
 import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
 import Language.Haskell.Brittany.Internal.Prelude
 import Language.Haskell.Brittany.Internal.Types
@@ -23,55 +26,56 @@ import Language.Haskell.Brittany.Internal.Utils
 layoutSigType :: ToBriDoc HsSigType
 -- TODO92 we ignore an ann here
 layoutSigType (L _ (HsSig _ outerVarBind typ)) = case outerVarBind of
-  HsOuterImplicit _ -> callLayouter layout_type typ
+  HsOuterImplicit _       -> callLayouter2 layout_type False typ
   HsOuterExplicit _ bndrs -> do
-    parts <- splitHsForallTypeFromBinders (map withoutSpecificity bndrs) typ
+    (headPart, restParts) <-
-    joinSplitArrowType (hasAnyCommentsBelow typ) parts
+      splitHsForallTypeFromBinders (map withoutSpecificity bndrs) typ
+    layoutSplitArrowType (headPart, restParts) (hasAnyCommentsBelow typ)
 
 splitArrowType
   :: LHsType GhcPs
-  -> ToBriDocM
+  -> ToBriDocM (OpTree, [(BriDocNumbered, OpTree)])
-       (ToBriDocM BriDocNumbered, [(String, ToBriDocM BriDocNumbered)])
 splitArrowType ltype@(L _ typ) = case typ of
   HsForAllTy NoExtField hsf typ1 ->
     splitHsForallTypeFromBinders (getBinders hsf) typ1
   HsQualTy NoExtField ctxMay typ1 -> do
     (innerHead, innerBody) <- splitArrowType typ1
-    (wrapCtx, cntxtDocs) <- case ctxMay of
+    (wrapCtx  , cntxtDocs) <- case ctxMay of
-      Nothing         -> pure (id, [])
+      Nothing                            -> pure (id, [])
       Just (L (SrcSpanAnn epAnn _) ctxs) -> do
-        let wrap = case epAnn of
+        let
-              EpAnn _ (AnnContext (Just (_, loc)) _ _) _ ->
+          wrap = case epAnn of
-                docFlushCommsPost False (Just $ epaLocationRealSrcSpanStart loc)
+            EpAnn _ (AnnContext (Just (_, loc)) _ _) _ ->
-                  . docHandleComms epAnn
+              docFlushCommsPost False (Just $ epaLocationRealSrcSpanStart loc)
-              _ -> docHandleComms epAnn
+                . docHandleComms epAnn
-        x <- ctxs `forM` (shareDoc . layoutType)
+            _ -> docHandleComms epAnn
+        x <- ctxs `forM` (shareDoc . layoutType False)
         pure (wrap, x)
-    pure
+    outerHead <- wrapCtx $ case cntxtDocs of
-      $ ( wrapCtx $ case cntxtDocs of
+      []   -> docLit $ Text.pack "()"
-            []   -> docLit $ Text.pack "()"
+      [x]  -> x
-            [x]  -> x
+      docs -> docAlt
-            docs -> docAlt
+        [ let
-              [ let
+              open  = docLit $ Text.pack "("
-                  open  = docLit $ Text.pack "("
+              close = docLit $ Text.pack ")"
-                  close = docLit $ Text.pack ")"
+              list  = List.intersperse docCommaSep $ docForceSingleline <$> docs
-                  list =
+          in  docSeq ([open] ++ list ++ [close])
-                    List.intersperse docCommaSep $ docForceSingleline <$> docs
+        , let
-                in
+            open =
-                  docSeq ([open] ++ list ++ [close])
+              docCols
-              , let open = docCols
+                ColTyOpPrefix
-                      ColTyOpPrefix
+                [docParenLSep
-                      [ docParenLSep
+                             , docAddBaseY (BrIndentSpecial 2) $ head docs
-                      , docAddBaseY (BrIndentSpecial 2) $ head docs
+                                                                          ]
-                      ]
+            close = docLit $ Text.pack ")"
-                    close = docLit $ Text.pack ")"
+            list  = List.tail docs <&> \cntxtDoc ->
-                    list  = List.tail docs <&> \cntxtDoc -> docCols
+              docCols ColTyOpPrefix
-                      ColTyOpPrefix
                       [docCommaSep, docAddBaseY (BrIndentSpecial 2) cntxtDoc]
-                in  docPar open $ docLines $ list ++ [close]
+          in
-              ]
+            docPar open $ docLines $ list ++ [close]
-        , (("=>", innerHead) : innerBody)
+        ]
-        )
+    arrowDoc <- docLitS "=>"
+    pure (OpLeaf outerHead, (arrowDoc, innerHead) : innerBody)
   HsFunTy epAnn _ typ1 typ2 -> do
     (typ1Doc, (innerHead, innerBody)) <- do
       let
@@ -89,71 +93,92 @@ splitArrowType ltype@(L _ typ) = case typ of
           EpAnn _ AddLollyAnnU{} _ ->
             error "brittany internal error: HsFunTy EpAnn"
           EpAnnNotUsed -> id
-      typ1Doc   <- docHandleComms epAnn $ wrapper $ layoutType typ1
+      typ1Doc   <- docHandleComms epAnn $ wrapper $ layoutType False typ1
       typ2Tuple <- splitArrowType typ2
       pure (typ1Doc, typ2Tuple)
-    pure $ (pure typ1Doc, ("->", innerHead) : innerBody)
+    arrowDoc <- docLitS "->"
-  _ -> pure (layoutType ltype, [])
+    pure $ (OpLeaf typ1Doc, (arrowDoc, innerHead) : innerBody)
+  HsParTy epAnn inner -> do
+    let AnnParen _ spanOpen spanClose = anns epAnn
+    (headPart, restParts) <- splitArrowType inner
+    pure
+      ( OpKnown ParenWithSpace
+                (Just $ epaLocationRealSrcSpanStart spanOpen)
+                (Just $ epaLocationRealSrcSpanStart spanClose)
+                (Fixity NoSourceText (-1) InfixN)
+                headPart
+                restParts
+      , []
+      )
+  HsOpTy{} -> do
+    (innerHead, innerRest) <- splitOpType ltype
+    pure $ (OpUnknown NoParen Nothing Nothing innerHead innerRest, [])
+  _ -> do
+    inner <- layoutType False ltype
+    pure (OpLeaf inner, [])
+
+splitOpType :: LHsType GhcPs -> ToBriDocM (OpTree, [(BriDocNumbered, OpTree)])
+splitOpType = \case
+  L _ (HsOpTy NoExtField l1 op1@(L (SrcSpanAnn _ pos) _) r1) -> do
+    docL <- layoutType False l1
+    docOp <- docHandleComms pos $ docLit $ printRdrNameWithAnns op1
+    (innerHead, innerBody) <- splitOpType r1
+    pure $ (OpLeaf docL, (docOp, innerHead) : innerBody)
+  ltype -> do
+    inner <- layoutType False ltype
+    pure (OpLeaf inner, [])
+
 
 splitHsForallTypeFromBinders
   :: [LHsTyVarBndr () GhcPs]
   -> LHsType GhcPs
   -> ToBriDocM
-       (ToBriDocM BriDocNumbered, [(String, ToBriDocM BriDocNumbered)])
+       (OpTree, [(BriDocNumbered, OpTree)])
 splitHsForallTypeFromBinders binders typ = do
   (innerHead, innerBody) <- splitArrowType typ
-  pure
+  outerHead <- do
-    $ ( do
+    tyVarDocs <- layoutTyVarBndrs binders
-        tyVarDocs <- layoutTyVarBndrs binders
+    docAlt
-        docAlt
+      -- :: forall x
-          -- :: forall x
+      --  . x
-          --  . x
+      [ let open = docLit $ Text.pack "forall"
-          [ let open = docLit $ Text.pack "forall"
+        in  docSeq (open : processTyVarBndrsSingleline tyVarDocs)
-            in  docSeq (open : processTyVarBndrsSingleline tyVarDocs)
+      -- :: forall
-          -- :: forall
+      --      (x :: *)
-          --      (x :: *)
+      --  . x
-          --  . x
+      , docPar
-          , docPar
+        (docLit (Text.pack "forall"))
-            (docLit (Text.pack "forall"))
+        (docLines $ tyVarDocs <&> \case
-            (docLines $ tyVarDocs <&> \case
+          (tname, Nothing) ->
-              (tname, Nothing) ->
+            docEnsureIndent BrIndentRegular $ docLit tname
-                docEnsureIndent BrIndentRegular $ docLit tname
+          (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines
-              (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines
+            [ docCols ColTyOpPrefix [docParenLSep, docLit tname]
-                [ docCols ColTyOpPrefix [docParenLSep, docLit tname]
+            , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc]
-                , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc]
+            , docLit $ Text.pack ")"
-                , docLit $ Text.pack ")"
+            ]
-                ]
+        )
-            )
-          ]
-      , (".", innerHead) : innerBody
-      )
-
-
-joinSplitArrowType
-  :: Bool
-  -> (ToBriDocM BriDocNumbered, [(String, ToBriDocM BriDocNumbered)])
-  -> ToBriDocM BriDocNumbered
-joinSplitArrowType hasComments (dHead, body) =
-  runFilteredAlternative $ do
-    addAlternativeCond (not hasComments)
-      $ docForceSingleline $ docSeq $ dHead : join
-        [ [docSeparator, docLit (Text.pack prefix), docSeparator, doc]
-        | (prefix, doc) <- body
-        ]
-    addAlternative $ docPar (docSetBaseY dHead) $ docLines
-      [ docCols
-          ColTyOpPrefix
-          [ appSep $ docLit $ Text.pack $ if length prefix < 2
-            then " " ++ prefix -- special case for "forall dot"
-                               -- in multi-line layout case
-            else prefix
-          , docEnsureIndent (BrIndentSpecial (length prefix + 1)) doc
-          ]
-      | (prefix, doc) <- body
       ]
+  dotDoc <- docLitS "."
+  pure (OpLeaf outerHead, (dotDoc, innerHead) : innerBody)
 
-layoutType :: ToBriDoc HsType
+layoutSplitArrowType
-layoutType ltype@(L _ typ) = docHandleComms ltype $ case typ of
+  :: (OpTree, [(BriDocNumbered, OpTree)])
+  -> Bool
+  -> ToBriDocM BriDocNumbered
+layoutSplitArrowType (headPart, restParts) hasComments = do
+  layouters <- mAsk
+  let opTree =
+        OpKnown NoParen
+                Nothing
+                Nothing
+                (Fixity NoSourceText (-1) InfixN)
+                headPart
+                restParts
+  layout_opTree layouters (opTree, hasComments)
+
+
+layoutType :: Bool -> ToBriDoc HsType
+layoutType forceHasComms ltype@(L _ typ) = docHandleComms ltype $ case typ of
   -- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible"
   HsTyVar epAnn promoted name -> docHandleComms epAnn $ do
     t <- lrdrNameToTextAnnTypeEqualityIsSpecial name
@@ -162,34 +187,20 @@ layoutType ltype@(L _ typ) = docHandleComms ltype $ case typ of
       NotPromoted -> docHandleComms name $ docLit t
   HsForAllTy{} -> do
     parts <- splitArrowType ltype
-    joinSplitArrowType (hasAnyCommentsBelow typ) parts
+    layoutSplitArrowType parts (hasAnyCommentsBelow typ || forceHasComms)
   HsQualTy{} -> do
     parts <- splitArrowType ltype
-    joinSplitArrowType (hasAnyCommentsBelow typ) parts
+    layoutSplitArrowType parts (hasAnyCommentsBelow typ || forceHasComms)
   HsFunTy{} -> do
     parts <- splitArrowType ltype
-    joinSplitArrowType (hasAnyCommentsBelow typ) parts
+    layoutSplitArrowType parts (hasAnyCommentsBelow typ || forceHasComms)
-  HsParTy epAnn typ1 -> docHandleComms epAnn $ do
+  HsParTy{} -> do
-    let (wrapOpen, wrapClose) = case epAnn of
+    -- layouters <- mAsk
-          EpAnn _ (AnnParen _ spanOpen spanClose) _ ->
+    -- treeAndHasComms <-
-            (docHandleComms spanOpen, docHandleComms spanClose)
+    --   layout_gatherOpTreeT layouters NoParen False id Nothing Nothing [] ltype
-          EpAnnNotUsed -> (id, id)
+    -- layout_opTree layouters True treeAndHasComms
-    typeDoc1 <- shareDoc $ layoutType typ1
+    parts <- splitArrowType ltype
-    docAlt
+    layoutSplitArrowType parts (hasAnyCommentsBelow typ || forceHasComms)
-      [ docSeq
-        [ wrapOpen $ docLit $ Text.pack "("
-        , docForceSingleline typeDoc1
-        , wrapClose $ docLit $ Text.pack ")"
-        ]
-      , docPar
-        (docCols
-          ColTyOpPrefix
-          [ wrapOpen $ docParenLSep
-          , docAddBaseY (BrIndentSpecial 2) $ typeDoc1
-          ]
-        )
-        (wrapClose $ docLit $ Text.pack ")")
-      ]
   HsAppTy NoExtField typ1@(L _ HsAppTy{}) typ2 -> do
     let
       gather
@@ -198,8 +209,8 @@ layoutType ltype@(L _ typ) = docHandleComms ltype $ case typ of
         L _ (HsAppTy _ ty1 ty2) -> gather (ty2 : list) ty1
         final -> (final, list)
     let (typHead, typRest) = gather [typ2] typ1
-    docHead <- shareDoc $ layoutType typHead
+    docHead <- shareDoc $ layoutType False typHead
-    docRest <- (shareDoc . layoutType) `mapM` typRest
+    docRest <- (shareDoc . layoutType False) `mapM` typRest
     docAlt
       [ docSeq
       $ docForceSingleline docHead
@@ -207,8 +218,8 @@ layoutType ltype@(L _ typ) = docHandleComms ltype $ case typ of
       , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest)
       ]
   HsAppTy NoExtField typ1 typ2 -> do
-    typeDoc1 <- shareDoc $ layoutType typ1
+    typeDoc1 <- shareDoc $ layoutType False typ1
-    typeDoc2 <- shareDoc $ layoutType typ2
+    typeDoc2 <- shareDoc $ layoutType False typ2
     docAlt
       [ docSeq
         [docForceSingleline typeDoc1, docSeparator, docForceSingleline typeDoc2]
@@ -219,21 +230,21 @@ layoutType ltype@(L _ typ) = docHandleComms ltype $ case typ of
           EpAnn _ (AnnParen _ spanOpen spanClose) _ ->
             (docHandleComms spanOpen, docHandleComms spanClose)
           EpAnnNotUsed -> (id, id)
-    typeDoc1 <- shareDoc $ layoutType typ1
+    typeDoc1 <- shareDoc $ layoutType False typ1
     docAlt
       [ docSeq
         [ wrapOpen $ docLit $ Text.pack "["
         , docForceSingleline typeDoc1
         , wrapClose $ docLit $ Text.pack "]"
         ]
-      , docPar
+      , docSetBaseY $ docLines
-        (docCols
+        [ docCols
           ColTyOpPrefix
           [ wrapOpen $ docLit $ Text.pack "[ "
           , docAddBaseY (BrIndentSpecial 2) $ typeDoc1
           ]
-        )
+        , wrapClose $ docLit $ Text.pack "]"
-        (wrapClose $ docLit $ Text.pack "]")
+        ]
       ]
   HsTupleTy epAnn tupleSort typs -> docHandleComms epAnn $ case tupleSort of
     HsUnboxedTuple -> unboxed
@@ -251,7 +262,7 @@ layoutType ltype@(L _ typ) = docHandleComms ltype $ case typ of
     wrapEnd   = docHandleComms close
     docWith start end = do
       typDocs <- typs `forM` \ty -> do
-        shareDoc $ docHandleListElemComms layoutType ty
+        shareDoc $ docHandleListElemComms (layoutType False) ty
       let
         line1 = docCols ColTyOpPrefix [wrapStart $ appSep start, head typDocs]
         lines =
@@ -269,9 +280,12 @@ layoutType ltype@(L _ typ) = docHandleComms ltype $ case typ of
             (docLines $ lines ++ [wrapEnd end])
         ]
   HsOpTy{} -> do
-    layouters <- mAsk
+    parts <- splitArrowType ltype
-    treeAndHasComms <- layout_gatherOpTreeT layouters False False id Nothing Nothing [] ltype
+    layoutSplitArrowType parts (hasAnyCommentsBelow ltype || forceHasComms)
-    layout_opTree layouters treeAndHasComms
+    -- layouters <- mAsk
+    -- treeAndHasComms <-
+    --   layout_gatherOpTreeT layouters NoParen False id Nothing Nothing [] ltype
+    -- layout_opTree layouters treeAndHasComms
   -- HsOpTy typ1 opName typ2 -> do
   --   -- TODO: these need some proper fixing. precedences don't add up.
   --   --       maybe the parser just returns some trivial right recursion
@@ -332,7 +346,7 @@ layoutType ltype@(L _ typ) = docHandleComms ltype $ case typ of
   --     }
   HsIParamTy epAnn (L _ (HsIPName ipName)) typ1 -> do
     let posColon = obtainAnnPos epAnn AnnDcolon
-    typeDoc1 <- shareDoc $ layoutType typ1
+    typeDoc1 <- shareDoc $ layoutType False typ1
     docHandleComms epAnn $ docAlt
       [ docSeq
         [ docLitS $ "?" ++ showSDocUnsafe (ftext ipName)
@@ -351,8 +365,8 @@ layoutType ltype@(L _ typ) = docHandleComms ltype $ case typ of
   -- TODO: test KindSig
   HsKindSig epAnn typ1 kind1 -> do
     let posColon = obtainAnnPos epAnn AnnDcolon
-    typeDoc1 <- shareDoc $ layoutType typ1
+    typeDoc1 <- shareDoc $ layoutType False typ1
-    kindDoc1 <- shareDoc $ layoutType kind1
+    kindDoc1 <- shareDoc $ layoutType False kind1
     docAlt
       [ docSeq
           [ docForceSingleline typeDoc1
@@ -371,7 +385,7 @@ layoutType ltype@(L _ typ) = docHandleComms ltype $ case typ of
           )
       ]
   HsBangTy epAnn (HsSrcBang NoSourceText NoSrcUnpack SrcStrict) innerTy -> do
-    docHandleComms epAnn $ docSeq [docLitS "!", layoutType innerTy]
+    docHandleComms epAnn $ docSeq [docLitS "!", layoutType False innerTy]
   HsBangTy {} ->
     briDocByExactInlineOnly "HsBangTy{}" ltype
   -- HsBangTy bang typ1 -> do
@@ -443,7 +457,8 @@ layoutType ltype@(L _ typ) = docHandleComms ltype $ case typ of
     -- rendering on a single line.
     let specialCommaSep = appSep $ docLit $ Text.pack " ,"
 
-    typDocs <- typs `forM` (shareDoc . docHandleListElemComms layoutType)
+    typDocs <-
+      typs `forM` (shareDoc . docHandleListElemComms (layoutType False))
     let hasComments = hasAnyCommentsBelow ltype
     case splitFirstLast typDocs of
       FirstLastEmpty -> docSeq
@@ -506,8 +521,8 @@ layoutType ltype@(L _ typ) = docHandleComms ltype $ case typ of
       else docLit $ Text.pack "*"
   XHsType{} -> error "brittany internal error: XHsType"
   HsAppKindTy _ ty kind -> do
-    t <- shareDoc $ layoutType ty
+    t <- shareDoc $ layoutType False ty
-    k <- shareDoc $ layoutType kind
+    k <- shareDoc $ layoutType False kind
     docAlt
       [ docSeq
         [ docForceSingleline t
@@ -525,7 +540,7 @@ layoutTyVarBndrs
 layoutTyVarBndrs = mapM $ \case
   (L _ (UserTyVar _ _ name)) -> return $ (lrdrNameToText name, Nothing)
   (L _ (KindedTyVar _ _ lrdrName kind)) -> do
-    d <- shareDoc $ layoutType kind
+    d <- shareDoc $ layoutType False kind
     return $ (lrdrNameToText lrdrName, Just $ d)
 
 -- there is no specific reason this returns a list instead of a single

source/library/Language/Haskell/Brittany/Internal/Transformations/T3_Par.hs

@@ -25,6 +25,8 @@ transformSimplifyPar = transformUp $ \case
     BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds))
   BDPar ind1 (BDPar ind2 line p1) p2 ->
     BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2])
+  BDLines [ BDPar BrIndentNone line (BDLines lines) ] ->
+    BDLines (line : lines)
   BDLines lines
     | any
       (\case
@@ -52,4 +54,8 @@ transformSimplifyPar = transformUp $ \case
   -- BDPar BrIndentNone line indented ->
   --   Just $ BDLines [line, indented]
   BDEnsureIndent BrIndentNone x -> x
+  -- This does not appear to make a difference, but seems the right
+  -- thing to do so I added it for now.
+  BDEnsureIndent ind (BDPar BrIndentNone line1 (BDLines linesR)) ->
+    BDEnsureIndent ind (BDLines (line1 : linesR))
   x -> x

source/library/Language/Haskell/Brittany/Internal/Transformations/T5_Indent.hs

@@ -15,9 +15,14 @@ import Language.Haskell.Brittany.Internal.Components.BriDoc
 -- affected by what amount of indentation.
 transformSimplifyIndent :: BriDoc -> BriDoc
 transformSimplifyIndent = Uniplate.rewrite $ \case
-  BDPar ind (BDLines lines) indented ->
+  -- BDPar ind (BDLines lines) indented ->
-    -- error "foo"
+  --   Just $ BDEnsureIndent ind $ BDLines $ lines ++ [indented]
-    Just $ BDEnsureIndent ind $ BDLines $ lines ++ [indented]
+  BDPar ind (BDLines (line1:lineR)) indented ->
+    Just
+      $  BDLines
+      $  [line1]
+      ++ fmap (BDEnsureIndent ind) lineR
+      ++ [BDEnsureIndent ind indented]
   BDPar ind (BDCols sig cols) indented ->
     Just $ BDCols sig (List.init cols ++ [BDPar ind (List.last cols) indented])
   BDPar BrIndentNone _ _ -> Nothing
@@ -51,5 +56,9 @@ transformSimplifyIndent = Uniplate.rewrite $ \case
   BDAddBaseY i (BDCols sig l) ->
     Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l]
   BDAddBaseY _ lit@BDLit{} -> Just lit
+  -- BDEnsureIndent (BrIndentSpecial a) (BDEnsureIndent (BrIndentSpecial b) x) ->
+  --   Just $ BDEnsureIndent (BrIndentSpecial (a + b)) x
+  -- BDEnsureIndent ind (BDCols op (c1:cR)) ->
+  --   Just $ BDCols op (BDEnsureIndent ind c1 : cR)
 
   _ -> Nothing

source/library/Language/Haskell/Brittany/Internal/Types.hs

@@ -160,13 +160,19 @@ type ToBriDocM = MultiRWSS.MultiRWS
   '[[BrittanyError], Seq String] -- writer
   '[NodeAllocIndex, CommentCounter] -- state
 
+data OpParenMode
+  = NoParen
+  | ParenNoSpace
+  | ParenWithSpace
+  deriving (Eq, Show)
+
 data OpTree
-  = OpUnknown Bool -- Z paren?
+  = OpUnknown OpParenMode -- Z paren?
               (Maybe GHC.RealSrcLoc) -- paren open loc
               (Maybe GHC.RealSrcLoc) -- paren close loc
               OpTree -- left operand
-              [(BriDocNumbered, BriDocNumbered)] -- list of (next operand, symbol)
+              [(BriDocNumbered, OpTree)] -- list of (next operand, symbol)
-  | OpKnown Bool     -- with paren?
+  | OpKnown OpParenMode     -- with paren?
               (Maybe GHC.RealSrcLoc) -- paren open loc
               (Maybe GHC.RealSrcLoc) -- paren close loc
             GHC.Fixity   -- only Just after (successful!) lookup phase
@@ -180,25 +186,25 @@ data Layouters = Layouters
   { layout_expr :: ToBriDoc GHC.HsExpr
   , layout_lit :: GHC.HsLit GhcPs -> BriDocWrapped
   , layout_overLit :: GHC.OverLitVal -> BriDocWrapped
-  , layout_type :: ToBriDoc GHC.HsType
+  , layout_type :: Bool -> ToBriDoc GHC.HsType
   , layout_sigType :: ToBriDoc GHC.HsSigType
   , layout_stmt :: GHC.GuardLStmt GhcPs -> ToBriDocM BriDocNumbered
   , layout_gatherOpTreeE
-    :: Bool
+    :: OpParenMode
     -> Bool
     -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered)
     -> Maybe GHC.RealSrcLoc
     -> Maybe GHC.RealSrcLoc
-    -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)]
+    -> [(ToBriDocM BriDocNumbered, OpTree)]
     -> GHC.LHsExpr GhcPs
     -> ToBriDocM (OpTree, Bool)
   , layout_gatherOpTreeT
-    :: Bool
+    :: OpParenMode
     -> Bool
     -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered)
     -> Maybe GHC.RealSrcLoc
     -> Maybe GHC.RealSrcLoc
-    -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)]
+    -> [(ToBriDocM BriDocNumbered, OpTree)]
     -> GHC.LHsType GhcPs
     -> ToBriDocM (OpTree, Bool)
   , layout_opTree :: (OpTree, Bool) -> ToBriDocM BriDocNumbered
@@ -276,6 +282,15 @@ callLayouter lens x = do
   layouters <- mAsk
   lens layouters x
 
+callLayouter2
+  :: (Layouters -> a -> b -> ToBriDocM r)
+  -> a
+  -> b
+  -> ToBriDocM r
+callLayouter2 lens x y = do
+  layouters <- mAsk
+  lens layouters x y
+
 
 type ToBriDoc (sym :: Kind.Type -> Kind.Type) = XRec GhcPs (sym GhcPs) -> ToBriDocM BriDocNumbered
 type ToBriDoc' sym            = XRec GhcPs (sym GhcPs)                 -> ToBriDocM BriDocNumbered