Fix bug in PRMMinimize feature for InfixN operators

I.e. not merging of items inside one import, but
merging imports of the same module (and the same
qualified name, if present etc.)

data/12-features/import-merging.blt

@@ -0,0 +1,45 @@
+#group feature/import-merging
+
+
+#golden merge imports down to constructor-level
+import           Data.Bool                                ( Bool(True) )
+import           Data.Bool                                ( Bool(False) )
+#expected
+import           Data.Bool                                ( Bool(False, True) )
+
+#golden wildcard trumps explicit+hiding
+import           Data.Map                                 ( Map )
+import           Data.Map
+import           Data.Map                          hiding ( toList )
+#expected
+import           Data.Map
+
+#golden explicit+hiding do not merge for now
+import           Data.Map                                 ( Map )
+import           Data.Map                          hiding ( toList )
+#expected
+import           Data.Map                                 ( Map )
+import           Data.Map                          hiding ( toList )
+
+#golden hiding+hiding do not merge for now
+import           Data.Map                          hiding ( toList )
+import           Data.Map                          hiding ( fromList )
+#expected
+import           Data.Map                          hiding ( toList )
+import           Data.Map                          hiding ( fromList )
+
+#golden qualified and qualified-as merge but separately
+import qualified Data.Map                                 ( toList )
+import qualified Data.Map                                 ( fromList )
+import qualified Data.Map                                as M
+                                                          ( Map )
+import qualified Data.Map                                as M
+                                                          ( take )
+#expected
+import qualified Data.Map                                 ( fromList
+                                                          , toList
+                                                          )
+import qualified Data.Map                                as M
+                                                          ( Map
+                                                          , take
+                                                          )

data/12-features/minimize-parentheses.blt

@@ -25,3 +25,7 @@ func = func ((((((((nested + expression))))))))
 #expected
 -- brittany { lconfig_operatorParenthesisRefactorMode: PRMMinimize }
 func = func (nested + expression)
+
+#test does not remove parens on InfixN
+-- brittany { lconfig_operatorParenthesisRefactorMode: PRMMinimize }
+func = (a == Foo) == (b == Bar)

data/15-regressions.blt

@@ -1113,3 +1113,16 @@ func = do
 func arg = abc ++ def ++ case arg of
   False -> ghi
   True  -> jkl
+
+#test non-idempotent comment position with let-in-where
+otherFunc very long patterrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrn
+  = let
+        localfunc a b c = a <> b <> c
+        someThing = fromList [abc, def, ghi]
+    in -- abc
+        aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
+        + bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb
+        + ccccccc
+ where
+  ccccccc = "abc"
+  ddddd   = True

data/30-tests-context-free.blt

@@ -1415,6 +1415,7 @@ foo =
 
 #test issue 176
 
+-- brittany { lconfig_unknownFixityHandling: UFHSafeIgnore }
 record :: Record
 record = Record
   { rProperties =

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

@@ -15,10 +15,13 @@ import           GHC.Types.Fixity               ( Fixity(Fixity)
 import           GHC.Types.SourceText           ( SourceText(NoSourceText) )
 import qualified Safe
 import qualified Data.Char
+import           Data.Data                      ( toConstr )
 
 import           Language.Haskell.Brittany.Internal.Components.BriDoc
 import           Language.Haskell.Brittany.Internal.Utils
 import           Language.Haskell.Brittany.Internal.Types
+import           Language.Haskell.Brittany.Internal.Config.Types
+                                                ( UnknownFixityHandling(..) )
 
 
 
@@ -35,7 +38,7 @@ displayOpTree = \case
          [ ("(" ++ showOp op ++ "," ++ displayOpTree x ++ ")") | (op, x) <- rs ]
     ++ "])"
     )
-  OpKnown p _ _ fixity tree ops ->
+  OpKnown p _ _ _ fixity tree ops ->
     (  "OpKnown "
     ++ show p
     ++ " "
@@ -84,45 +87,44 @@ data ReformatParenMode
 -- || (== a (+ b c)), /= (* d e) f
 -- || (== a (+ b c)) (/= (* d e) f)
 
-data StackElem = StackElem Fixity [(OpTree, BriDocNumbered)]
+data StackElem = StackElem (Bool, Fixity) [(OpTree, BriDocNumbered)]
 type Stack = [StackElem]
 
-balanceOpTree :: Bool -> OpTree -> ([BrittanyError], OpTree)
+balanceOpTree
-balanceOpTree allowUnqualify = \case
+  :: UnknownFixityHandling -> Bool -> OpTree -> ([BrittanyError], OpTree)
-  x@OpLeaf{} -> ([], x)
+balanceOpTree unknownFixityHandling allowUnqualify = outer
-  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
-    in  case go [] rest balancedLeft of
-          Right (leaf@OpLeaf{}) -> (warns, leaf)
-          Right (OpKnown _paren _ _ fixity c cs) ->
-            (warns, OpKnown paren locO locC fixity c cs)
-          Right t -> (warns, t)
-          Left moreWarns ->
-            ( (  warns
-              ++ [ LayoutWarning ("Fixity of operator not known: " ++ w)
-                 | w <- moreWarns
-                 ]
-              )
-            , x
-            )
  where
+  outer = \case
+    x@OpLeaf{} -> ([], x)
+    OpKnown paren allowT locO locC fixity@(Fixity _ (-1) _) left rest ->
+      let
+          (warnsLeft, balancedLeft) = outer left
+          opRes = [ (op, outer argTree) | (op, argTree) <- rest ]
+      in  ( warnsLeft ++ [ w | (_, (warns, _)) <- opRes, w <- warns ]
+          , OpKnown paren
+                    allowT
+                    locO
+                    locC
+                    fixity
+                    balancedLeft
+                    [ (op, balanced) | (op, (_, balanced)) <- opRes ]
+          )
+    x@OpKnown{} -> ([], x)
+    x@(OpUnknown paren locO locC left rest) ->
+      let (warns, balancedLeft) = outer left
+      in  case go [] rest balancedLeft of
+            Right (leaf@OpLeaf{}) -> (warns, leaf)
+            Right (OpKnown _paren allowT _ _ fixity c cs) ->
+              (warns, OpKnown paren allowT locO locC fixity c cs)
+            Right t         -> (warns, t)
+            Left  moreWarns -> ((warns ++ moreWarns), x)
   -- singleton :: BriDocNumbered -> StackElem
   -- singleton x = StackElem (Fixity NoSourceText 99 InfixN) (OpLeaf x) []
-  go :: Stack -> [(BriDocNumbered, OpTree)] -> OpTree -> Either [String] OpTree
+  go
+    :: Stack
+    -> [(BriDocNumbered, OpTree)]
+    -> OpTree
+    -> Either [BrittanyError] OpTree
   go [] [] _ = Left []
   go [StackElem fxty cs] [] c =
     let (e1, eops) = shiftOps cs c in Right (known fxty e1 eops)
@@ -135,8 +137,8 @@ balanceOpTree allowUnqualify = \case
       fxty <- docFixity opDoc
       go [StackElem fxty [(c, opDoc)]] inputR val
     (StackElem fixityS cs : stackR) -> do
-      let Fixity _ precS dirS = fixityS
+      let (_, Fixity _ precS dirS) = fixityS
-      fxty@(Fixity _ prec dir) <- docFixity opDoc
+      fxty@(_, Fixity _ prec dir) <- docFixity opDoc
       case compare prec precS of
         GT -> go (StackElem fxty [(c, opDoc)] : stack) inputR val
         LT -> do
@@ -148,14 +150,26 @@ balanceOpTree allowUnqualify = \case
           (InfixL, InfixL) ->
             go (StackElem fixityS ((c, opDoc) : cs) : stackR) inputR val
           _ -> Left []
-  docFixity :: BriDocNumbered -> Either [String] Fixity
+  docFixity :: BriDocNumbered -> Either [BrittanyError] (Bool, Fixity)
   docFixity (_, x) = case x of
     BDLit (Text.unpack -> s) -> case hardcodedFixity allowUnqualify s of
-      Just f  -> Right f
+      Just f  -> Right (True, f)
-      Nothing -> Left [s]
+      Nothing -> case unknownFixityHandling of
+        UFHSafeWarn -> Left
+          [LayoutWarning ("Fixity of operator not known: " ++ s)]
+        UFHSafeIgnore       -> Left []
+        UFHDefaultFixity    -> Right (False, defaultFixity)
+        UFHDangerousDefault -> Right (True, defaultFixity)
     BDFlushCommentsPrior _ d -> docFixity d
     BDQueueComments      _ d -> docFixity d
-    _                        -> Left []
+    _                        -> Left
+      [ ( LayoutWarning
+        $ "internal brittany warning: "
+          ++ "Unknown form of operator "
+          ++ show (toConstr x)
+          ++ "!"
+        )
+      ]
   shiftOps
     :: [(OpTree, BriDocNumbered)]
     -> OpTree
@@ -168,31 +182,29 @@ balanceOpTree allowUnqualify = \case
               mapAccumL (\op (nextE, nextOp) -> (nextOp, (op, nextE))) o1 rest
         in  list ++ [(finalOp, final)]
       )
-  known = OpKnown NoParen Nothing Nothing
+  known (allowT, fixity) = OpKnown NoParen allowT Nothing Nothing fixity
 
 addAllParens :: OpParenMode -> OpTree -> OpTree
 addAllParens topLevelParen = \case
-  x@OpLeaf{}    -> x
+  OpKnown _paren True locO locC fixity c cs ->
-  x@OpUnknown{} -> x
-  OpKnown _paren locO locC fixity c cs ->
     OpKnown topLevelParen
+            True
             locO
             locC
             fixity
             (addAllParens ParenWithSpace c)
             [ (op, addAllParens ParenWithSpace tree) | (op, tree) <- cs ]
+  x -> x
 
 remSuperfluousParens :: Int -> OpTree -> OpTree
 remSuperfluousParens outerFixity = \case
-  x@OpLeaf{} -> x
   OpUnknown _ locO locC c@(OpLeaf _ doc) [] | isLit doc ->
     OpUnknown NoParen locO locC c []
   OpUnknown _ locO locC c@(OpUnknown ParenWithSpace _ _ _ _) [] ->
     OpUnknown NoParen locO locC (remSuperfluousParens 11 c) []
   OpUnknown _ locO locC c@(OpUnknown ParenNoSpace _ _ _ _) [] ->
     OpUnknown NoParen locO locC (remSuperfluousParens 11 c) []
-  x@OpUnknown{} -> x
+  OpKnown paren True locO locC fixity c cs ->
-  OpKnown paren locO locC fixity c cs ->
     OpKnown
       -- We do not support removing superfluous parens around
       -- function types yet:
@@ -200,11 +212,19 @@ remSuperfluousParens outerFixity = \case
         then paren
         else NoParen
       )
+      True
       locO
       locC
       fixity
-      (remSuperfluousParens (fixLevel fixity) c)
+      (remSuperfluousParens
+        (case fixity of
+          Fixity _ level InfixN -> level + 1
+          Fixity _ level _      -> level
+        )
+        c
+      )
       [ (op, remSuperfluousParens (fixLevel fixity) tree) | (op, tree) <- cs ]
+  x -> x
  where
   fixLevel (Fixity _ i _) = i
   isLit = \case
@@ -310,10 +330,19 @@ hardcodedFixity allowUnqualify = \case
   ".>"          -> Just $ Fixity NoSourceText 9 InfixL
   ":?"          -> Just $ Fixity NoSourceText 7 InfixN
   ":-"          -> Just $ Fixity NoSourceText 9 InfixR
-  ".:"          -> Just $ Fixity NoSourceText 9 InfixR
   "$!!"         -> fixity InfixR 0
   "<$!!>"       -> fixity InfixL 4
 
+  -- aeson
+  -- ".=" -> fixity InfixR 8 -- this clashes with lens :(
+  ".?="         -> fixity InfixR 8
+  ".:"          -> fixity InfixL 9
+  ".:!"         -> fixity InfixL 9
+  ".:?"         -> fixity InfixL 9
+  ".!="         -> fixity InfixL 9
+  ".:?="        -> fixity InfixL 9
+  ".:!="        -> fixity InfixL 9
+
   -- lens, not complete!
   "<|"          -> fixity InfixR 5
   "|>"          -> fixity InfixL 5
@@ -331,7 +360,7 @@ hardcodedFixity allowUnqualify = \case
   "**~"         -> fixity InfixR 4
   "||~"         -> fixity InfixR 4
   "&&~"         -> fixity InfixR 4
-  ".="          -> fixity InfixN 4
+  -- ".="          -> fixity InfixN 4 -- this clashes with aeson :(
   "%="          -> fixity InfixN 4
   "?="          -> fixity InfixN 4
   "+="          -> fixity InfixN 4
@@ -382,8 +411,6 @@ hardcodedFixity allowUnqualify = \case
   "==>"         -> fixity InfixR 0
   "=/="         -> fixity InfixN 4
   "==="         -> fixity InfixN 4
-  ".:!"         -> fixity InfixL 9
-  ".:?"         -> fixity InfixL 9
   -- ".:>"       -> fixity _ _
   -- ".:>?"      -> fixity _ _
   "<.>"         -> fixity InfixR 7
@@ -455,3 +482,6 @@ hardcodedFixity allowUnqualify = \case
       $ dropWhile (\x -> (Data.Char.isAlpha x || x == '.')) str
     _ -> Nothing
   where fixity a b = Just (Fixity NoSourceText b a)
+
+defaultFixity :: Fixity
+defaultFixity = Fixity NoSourceText 9 InfixL

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

@@ -61,6 +61,7 @@ staticDefaultConfig = Config
     -- , _lconfig_allowSinglelineRecord     = coerce False
     , _lconfig_fixityAwareOps = coerce True
     , _lconfig_fixityAwareTypeOps = coerce False
+    , _lconfig_unknownFixityHandling = coerce UFHSafeWarn
     , _lconfig_fixityBasedAddAlignParens = coerce False
     , _lconfig_operatorParenthesisRefactorMode = coerce PRMKeep
     , _lconfig_operatorAllowUnqualify = coerce True
@@ -167,6 +168,7 @@ cmdlineConfigParser = do
       , _lconfig_allowSinglelineRecord     = mempty
       , _lconfig_fixityAwareOps = mempty
       , _lconfig_fixityAwareTypeOps = mempty
+      , _lconfig_unknownFixityHandling = mempty
       , _lconfig_fixityBasedAddAlignParens = mempty
       , _lconfig_operatorParenthesisRefactorMode = mempty
       , _lconfig_operatorAllowUnqualify = mempty

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

@@ -160,6 +160,7 @@ data CLayoutConfig f = LayoutConfig
   , _lconfig_fixityAwareTypeOps :: f (Last Bool)
     -- Same as above, but for type-level operators. Not yet implemented, but
     -- reserved for future use.
+  , _lconfig_unknownFixityHandling :: f (Last UnknownFixityHandling)
   , _lconfig_fixityBasedAddAlignParens :: f (Last Bool)
     -- Layouts multiple-line operator applications with parentheses if
     -- permitted by layout. Note how the arguments are properly aligned:
@@ -285,6 +286,33 @@ data CPPMode = CPPModeAbort  -- abort program on seeing -XCPP
                              -- file.)
   deriving (Show, Generic, Data)
 
+data UnknownFixityHandling
+  = UFHSafeWarn
+    -- ^ If there are operators with unknown fixitiy, then
+    --   1) all operators in this operator-expression will be treated as
+    --      having the same fixity
+    --   2) A warning will be emitted
+    --   3) No transformations (parenthesis normalisation) will be performed
+  | UFHSafeIgnore
+    -- ^ Same as UFHWarning, but without step 2)
+  | UFHDefaultFixity
+    -- ^ Any operators with unknown fixity will be assigned the default
+    --   fixity, InfixL 9, and fixity-aware layouting will proceed for this
+    --   operator-expression. However, non-whitespace transformations will
+    --   be disable to prevent changed semantics.
+  | UFHDangerousDefault
+    -- ^ Like UFHDefaultFixity this assigns default fixity InfixL 9 to unknown
+    --   operators, but it even allows non-whitespace transformations.
+    --   This is dangerous!
+    --   Consider that for an expression such as `a <+> (b ***** c)`, where
+    --   the fixity of the hypothetical operator `*****` is unknown, the
+    --   "remove redundant parentheses" mode would yield `a <+> b ***** c`.
+    --   However, if the true fixity is `infixl 2 *****` then this
+    --   transformation does not retain semantics which may or may not
+    --   lead to type-errors.
+    --   This is the same as UFHDefaultFixity iff ParenRefactorMode is PRMKeep.
+  deriving (Show, Generic, Data)
+
 data ExactPrintFallbackMode
   = ExactPrintFallbackModeNever  -- never fall back on exactprinting
   | ExactPrintFallbackModeInline -- fall back only if there are no newlines in

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

@@ -68,6 +68,13 @@ instance ToJSON CPPMode where
   toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany
   toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany
 
+instance FromJSON UnknownFixityHandling where
+  parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany
+
+instance ToJSON UnknownFixityHandling where
+  toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany
+  toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany
+
 instance FromJSON ExactPrintFallbackMode where
   parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany
 

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

@@ -47,6 +47,7 @@ import           GHC                            ( AddEpAnn(AddEpAnn)
                                                   )
                                                 , SrcSpanAnn'(SrcSpanAnn)
                                                 , anchor
+                                                , getLoc
                                                 , ideclName
                                                 , moduleName
                                                 , moduleNameString
@@ -63,6 +64,7 @@ import           GHC.Types.Name.Reader          ( RdrName
                                                   , Unqual
                                                   )
                                                 )
+import           GHC.Types.SourceText           ( SourceText(NoSourceText) )
 import qualified GHC.OldList                   as List
 import           GHC.Parser.Annotation          ( DeltaPos
                                                   ( DifferentLine
@@ -88,16 +90,15 @@ import           Language.Haskell.Brittany.Internal.Types
 
 
 extractDeclMap :: GHC.ParsedSource -> Map GHC.RealSrcSpan [String]
-extractDeclMap modul =
+extractDeclMap modul = Map.fromList
-  Map.fromList
+  [ ( case span of
-    [ ( case span of
+        GHC.RealSrcSpan s _ -> s
-          GHC.RealSrcSpan s _ -> s
+        GHC.UnhelpfulSpan _ -> error "unexpected UnhelpfulSpan"
-          GHC.UnhelpfulSpan _ -> error "unexpected UnhelpfulSpan"
+    , getDeclBindingNames decl
-      , getDeclBindingNames decl
+    )
-      )
+  | decl <- decls
-    | decl <- decls
+  , let (L (GHC.SrcSpanAnn _ span) _) = decl
-    , let (L (GHC.SrcSpanAnn _ span) _) = decl
+  ]
-    ]
   where (L _ (GHC.HsModule _ _ _ _ _ decls _ _)) = modul
 
 splitModuleDecls :: GHC.ParsedSource -> FinalList ModuleElement ExactPrint.Pos
@@ -140,7 +141,7 @@ splitModuleDecls lmod = do
   spanAfterImports <- do
     finalYield $ MEExactModuleHead moduleWithoutComments
     pure
-      $  maybe (0, 1) (ExactPrint.ss2posEnd)
+      $  maybe (0, 1) ExactPrint.ss2posEnd
       $  maximumMay
       $  [ GHC.anchor a
          | L a _ <- GHC.priorComments $ case hsModAnn' of
@@ -265,7 +266,7 @@ enrichDecls lastSpanEnd = \case
 data ImportLine
   = EmptyLines Int
   | SamelineComment (Int, LEpaComment)
-  | NewlineComment  (Int, LEpaComment) -- indentation and comment
+  | NewlineComment (Int, LEpaComment) -- indentation and comment
   | ImportStatement ImportStatementRecord
 
 instance Show ImportLine where
@@ -274,8 +275,10 @@ instance Show ImportLine where
     SamelineComment{} -> "SamelineComment"
     NewlineComment{}  -> "NewlineComment"
     ImportStatement r ->
-      "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
+      "ImportStatement "
-        (length $ commentsAfter r)
+        ++ show (length $ commentsBefore r)
+        ++ " "
+        ++ show (length $ commentsAfter r)
 
 data ImportStatementRecord = ImportStatementRecord
   { commentsBefore   :: [(Int, LEpaComment)]
@@ -286,8 +289,10 @@ data ImportStatementRecord = ImportStatementRecord
 
 instance Show ImportStatementRecord where
   show r =
-    "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
+    "ImportStatement "
-      (length $ commentsAfter r)
+      ++ show (length $ commentsBefore r)
+      ++ " "
+      ++ show (length $ commentsAfter r)
 
 
 transformToImportLine
@@ -341,8 +346,9 @@ transformToImportLine startPos is =
   in
     flattenDecls is startPos
 
-data Partial = PartialCommsOnly [(Int, LEpaComment)]
+data Partial
-             | PartialImport ImportStatementRecord
+  = PartialCommsOnly [(Int, LEpaComment)]
+  | PartialImport ImportStatementRecord
 
 groupifyImportLines :: [ImportLine] -> [ImportLine]
 groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls
@@ -352,7 +358,8 @@ groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls
       finalYield $ NewlineComment comm
     PartialImport partialRecord ->
       finalYield $ ImportStatement $ unpartial partialRecord
-  go acc (line1 : lineR) = do
+  go acc (EmptyLines 0 : lineR) = go acc lineR
+  go acc (line1        : lineR) = do
     newAcc <- case acc of
       PartialCommsOnly comms -> case line1 of
         e@EmptyLines{} -> do
@@ -403,18 +410,8 @@ groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls
 
 sortCommentedImports :: [ImportLine] -> [ImportLine]
 sortCommentedImports =
-  -- TODO92 we don't need this unpackImports, it is implied later in the process
+  mergeGroups . map (fmap (combineImports . sortGroups)) . groupify
-  mergeGroups . map (fmap (sortGroups)) . groupify
  where
-  -- unpackImports :: [ImportLine] -> [ImportLine]
-  -- unpackImports xs = xs >>= \case
-  --   l@EmptyLines{}      -> [l]
-  --   l@NewlineComment{}  -> [l]
-  --   l@SamelineComment{} -> [l]
-  --   ImportStatement r ->
-  --     map NewlineComment (commentsBefore r) ++ [ImportStatement r] ++ map
-  --       NewlineComment
-  --       (commentsAfter r)
   mergeGroups :: [Either ImportLine [ImportStatementRecord]] -> [ImportLine]
   mergeGroups xs = xs >>= \case
     Left  x -> [x]
@@ -422,6 +419,61 @@ sortCommentedImports =
   sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord]
   sortGroups = List.sortOn
     (moduleNameString . unLoc . ideclName . unLoc . importStatement)
+  combineImports :: [ImportStatementRecord] -> [ImportStatementRecord]
+  combineImports = go Nothing
+   where
+    go Nothing   []        = []
+    go (Just r1) []        = [r1]
+    go Nothing   (r2 : rs) = go (Just r2) rs
+    go (Just r1) (r2 : rs) = case (unpack r1, unpack r2) of
+      (Nothing, _      ) -> r1 : go (Just r2) rs
+      (_      , Nothing) -> r1 : go (Just r2) rs
+      (Just u1, Just u2) ->
+        let
+            (modName1, pkg1, src1, safe1, q1, alias1, mllies1) = u1
+            (modName2, pkg2, src2, safe2, q2, alias2, mllies2) = u2
+            inner1 = GHC.unLoc $ importStatement r1
+            mostThingsEqual =
+              modName1 == modName2
+                && pkg1 == pkg2
+                && src1 == src2
+                && safe1 == safe2
+                && ((q1 == GHC.NotQualified) == (q2 == GHC.NotQualified))
+                && (unLoc <$> alias1) == (unLoc <$> alias2)
+            merged explicits =
+              go
+                (Just ImportStatementRecord
+                  { commentsBefore   = commentsBefore r1 ++ commentsBefore r2
+                  , importStatement  =
+                    L (getLoc $ importStatement r1) GHC.ImportDecl
+                      { GHC.ideclExt       = GHC.ideclExt inner1
+                      , GHC.ideclSourceSrc = NoSourceText
+                      , GHC.ideclName      = GHC.ideclName inner1
+                      , GHC.ideclPkgQual   = pkg1
+                      , GHC.ideclSource    = src1
+                      , GHC.ideclSafe      = safe1
+                      , GHC.ideclQualified = q1
+                      , GHC.ideclImplicit  = False
+                      , GHC.ideclAs        = alias1
+                      , GHC.ideclHiding    = explicits
+                      }
+                  , commentsSameline = (  commentsSameline r1
+                                       ++ commentsSameline r2
+                                       )
+                  , commentsAfter    = commentsAfter r1 ++ commentsAfter r2
+                  }
+                )
+                rs
+        in  case (mostThingsEqual, mllies1, mllies2) of
+              (True, Nothing         , _               ) -> merged Nothing
+              (True, _               , Nothing         ) -> merged Nothing
+              (True, Just (False, l1), Just (False, l2)) -> merged
+                (Just (False, L (getLoc l1) (unLoc l1 ++ unLoc l2)))
+              _ -> r1 : go (Just r2) rs
+    unpack x = case unLoc $ importStatement x of
+      GHC.ImportDecl _ _ (L _ modName) pkg src safe q False alias mllies ->
+        Just (modName, pkg, src, safe, q, alias, mllies)
+      _ -> Nothing
   groupify :: [ImportLine] -> [Either ImportLine [ImportStatementRecord]]
   groupify cs = go [] cs
    where
@@ -449,7 +501,7 @@ rdrNameToText (Exact name) = Text.pack $ getOccString name
 
 getDeclBindingNames :: GHC.LHsDecl GhcPs -> [String]
 getDeclBindingNames (L _ decl) = case decl of
-  GHC.SigD _ (GHC.TypeSig _ ns _) ->
+  GHC.SigD _ (GHC.TypeSig _ ns _) -> ns <&> \(L _ n) ->
-    ns <&> \(L _ n) -> Text.unpack (rdrNameToText n)
+    Text.unpack (rdrNameToText n)
   GHC.ValD _ (GHC.FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n]
   _ -> []

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

@@ -553,10 +553,11 @@ layoutExpr lexpr@(L _ expr) = do
               ]
             , docAlt
               [ docSeq
-                [ appSep $ wrapIn $ docLit $ Text.pack $ ifIndentFreeElse
+                [ appSep $ wrapIn $ docLit $ Text.pack "in"
-                  "in "
+                , ifIndentFreeElse ( docSetBaseAndIndent
-                  "in"
+                                   . docEnsureIndent (BrIndentSpecial 1)
-                , ifIndentFreeElse docSetBaseAndIndent
+                                   . docSetBaseAndIndent
+                                   )
                                    docForceSingleline
                                    expDoc1
                 ]
@@ -585,7 +586,8 @@ layoutExpr lexpr@(L _ expr) = do
                   $ docSetBaseAndIndent $ docLines $ pure <$> bindDocs
                   )
                 , docSeq
-                  [ wrapIn $ docLit $ Text.pack "in "
+                  [ wrapIn $ docLit $ Text.pack "in"
+                  , docSeparator
                   , docAddBaseY BrIndentRegular $ docForceParSpacing expDoc1
                   ]
                 ]
@@ -598,8 +600,10 @@ layoutExpr lexpr@(L _ expr) = do
                 , wrapBinds $ docSetBaseAndIndent $ docLines $ pure <$> bindDocs
                 ]
               , docSeq
-                [ appSep $ wrapIn $ docLit $ Text.pack "in "
+                [ appSep $ wrapIn $ docLit $ Text.pack "in"
-                , docSetBaseY expDoc1
+                , docSetBaseY
+                  $ docEnsureIndent (BrIndentSpecial 1)
+                  $ docSetBaseY expDoc1
                 ]
               ]
           addAlternative $ docLines

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

@@ -154,11 +154,12 @@ gatherOpTreeT hasParen hasComms commWrap locOpen locClose opExprList = \case
 
 processOpTree :: (OpTree, Bool) -> ToBriDocM BriDocNumbered
 processOpTree (unknownTree, hasComments) = do
-  enabled          <- askLayoutConf _lconfig_fixityAwareOps
+  enabled               <- askLayoutConf _lconfig_fixityAwareOps
-  refactorMode     <- askLayoutConf _lconfig_operatorParenthesisRefactorMode
+  refactorMode <- askLayoutConf _lconfig_operatorParenthesisRefactorMode
-  allowOpUnqualify <- askLayoutConf _lconfig_operatorAllowUnqualify
+  allowOpUnqualify      <- askLayoutConf _lconfig_operatorAllowUnqualify
+  unknownFixityHandling <- askLayoutConf _lconfig_unknownFixityHandling
   let (warns, balancedTree) = if enabled
-        then balanceOpTree allowOpUnqualify unknownTree
+        then balanceOpTree unknownFixityHandling allowOpUnqualify unknownTree
         else ([], unknownTree)
   mTell warns
   let processedTree = case refactorMode of
@@ -182,7 +183,7 @@ layoutOpTree allowSinglelinePar = \case
                     sharedOps
                     sharedOps
                     docForceSingleline
-  OpKnown NoParen Nothing Nothing fixity treeL docOps
+  OpKnown NoParen _ Nothing Nothing fixity treeL docOps
     | Fixity _ (-1) _ <- fixity -> do
       dHead <- shareDoc $ layoutOpTree True treeL
       body  <- forM docOps $ \(op, arg) -> do
@@ -209,7 +210,7 @@ layoutOpTree allowSinglelinePar = \case
               ]
           | (prefix, doc) <- body
           ]
-  OpKnown hasParen locO locC fixity treeL docOps -> do
+  OpKnown hasParen _ locO locC fixity treeL docOps -> do
     let Fixity _ _prec _ = fixity
     let flattenList ops = case ops of
           []           -> pure []
@@ -224,7 +225,7 @@ layoutOpTree allowSinglelinePar = \case
             pure $ (pure op1, tree1Doc) : flattenRest
           _ -> simpleTransform ops
         flattenInner op = \case
-          OpKnown NoParen _ _ _ innerL innerOps | isPrec0 fixity -> do
+          OpKnown NoParen _ _ _ _ innerL innerOps | isPrec0 fixity -> do
             flattenList ((op, innerL) : innerOps)
           tree -> do
             treeDoc <- shareDoc $ layoutOpTree True tree

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

@@ -103,6 +103,7 @@ splitArrowType ltype@(L _ typ) = case typ of
     (headPart, restParts) <- splitArrowType inner
     pure
       ( OpKnown ParenWithSpace
+                False
                 (Just $ epaLocationRealSrcSpanStart spanOpen)
                 (Just $ epaLocationRealSrcSpanStart spanClose)
                 (Fixity NoSourceText (-1) InfixN)
@@ -169,6 +170,7 @@ layoutSplitArrowType (headPart, restParts) hasComments = do
   layouters <- mAsk
   let opTree =
         OpKnown NoParen
+                False
                 Nothing
                 Nothing
                 (Fixity NoSourceText (-1) InfixN)

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

@@ -172,12 +172,13 @@ data OpTree
               (Maybe GHC.RealSrcLoc) -- paren close loc
               OpTree -- left operand
               [(BriDocNumbered, OpTree)] -- list of (next operand, symbol)
-  | OpKnown OpParenMode     -- with paren?
+  | OpKnown   OpParenMode     -- with paren?
+              Bool            -- allow non-whitespace transforms
               (Maybe GHC.RealSrcLoc) -- paren open loc
               (Maybe GHC.RealSrcLoc) -- paren close loc
-            GHC.Fixity   -- only Just after (successful!) lookup phase
+              GHC.Fixity   -- only Just after (successful!) lookup phase
-            OpTree
+              OpTree
-            [(BriDocNumbered, OpTree)]
+              [(BriDocNumbered, OpTree)]
   | OpLeaf Bool BriDocNumbered -- bool determines if parspacing is preferred
 
 data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted

source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/Operators.hs

@@ -143,7 +143,7 @@ layoutWriteComment absolute isBlock dp commentLines s = do
     ' '
   mTell $ Text.Builder.fromText s
   traceLocal
-    ( "layoutMoveToCommentPos"
+    ( "layoutWriteComment"
     , y
     , x
     , commentLines

source/test-suite/Main.hs

@@ -326,6 +326,7 @@ defaultTestConfig = Config
     , _lconfig_allowSinglelineRecord           = coerce False
     , _lconfig_fixityAwareOps                  = coerce True
     , _lconfig_fixityAwareTypeOps              = coerce True
+    , _lconfig_unknownFixityHandling           = coerce UFHSafeWarn
     , _lconfig_fixityBasedAddAlignParens       = coerce False
     , _lconfig_operatorParenthesisRefactorMode = coerce PRMKeep
     , _lconfig_operatorAllowUnqualify          = coerce True