Properly handle comments at the end of imports

comments between top-level decls should be considered
for inline-config. But despite being placed between
top-level decls, occasionally they get connected
somewhere nested inside the AST of the first decl.
We fix this by extracting such comments in a
pre-processing step. The control flow was significantly
altered to allow for this;
before:
  parsing -> extract inline configs
          -> compute final config(s)
          -> split module into head/decls/comments/whitespace
          -> ... bridoc -> transformations -> printing
after:
  parsing -> split module into head/decl/comments/whitespace
          -> extract inline configs respecting comments that
             got extracted from decls in the previous step
          -> compute final config(s)
          -> ... bridoc -> transformations -> printing

brittany.cabal

@@ -126,9 +126,6 @@ library
     Language.Haskell.Brittany.Internal.Config.Types
     Language.Haskell.Brittany.Internal.Config.Types.Instances1
     Language.Haskell.Brittany.Internal.Config.Types.Instances2
-    Language.Haskell.Brittany.Internal.ParseExact
-    Language.Haskell.Brittany.Internal.SplitExactModule
-    Language.Haskell.Brittany.Internal.ToBriDoc.Comment
     Language.Haskell.Brittany.Internal.ToBriDoc.DataDecl
     Language.Haskell.Brittany.Internal.ToBriDoc.Decl
     Language.Haskell.Brittany.Internal.ToBriDoc.Expr
@@ -143,10 +140,11 @@ library
     Language.Haskell.Brittany.Internal.Components.BriDoc
     Language.Haskell.Brittany.Internal.Components.Obfuscation
     Language.Haskell.Brittany.Internal.Components.OpTree
-    Language.Haskell.Brittany.Internal.ToBriDocTools
-    Language.Haskell.Brittany.Internal.WriteBriDoc
-    Language.Haskell.Brittany.Internal.PerModule
-    Language.Haskell.Brittany.Internal.PerDecl
+    Language.Haskell.Brittany.Internal.S1_Parsing
+    Language.Haskell.Brittany.Internal.S2_SplitModule
+    Language.Haskell.Brittany.Internal.S3_ToBriDocTools
+    Language.Haskell.Brittany.Internal.S4_WriteBriDoc
+    Language.Haskell.Brittany.Internal.StepOrchestrate
     Language.Haskell.Brittany.Internal.Prelude
     Language.Haskell.Brittany.Internal.Transformations.T1_Alt
     Language.Haskell.Brittany.Internal.Transformations.T2_Floating
@@ -158,6 +156,7 @@ library
     Language.Haskell.Brittany.Internal.WriteBriDoc.Types
     Language.Haskell.Brittany.Internal.Types
     Language.Haskell.Brittany.Internal.Utils
+    Language.Haskell.Brittany.Internal.Util.AST
     Paths_brittany
 
 executable brittany

data/10-structured/expression-list.blt

@@ -1,23 +0,0 @@
-#group expression/list
-
-#golden list format into singleline should not keep spacing
-foo =
-  [ 1
-  , 2
-  , 3
-  , 4
-  , 5
-  ]
-#expected
-foo = [1, 2, 3, 4, 5]
-
-#golden singleline list with comment
-foo = [1 {- a -}, {- b -} 2, {- c -} 3, 4, 5]
-#expected
-foo =
-  [ 1 {- a -}
-  , {- b -} 2
-  , {- c -} 3
-  , 4
-  , 5
-  ]

data/10-structured/op-precedence.blt

@@ -232,12 +232,3 @@ meow =
      , something
      ]
   )
-
-#test operator-paren-alignment inside do and other op
-func = do
-  other
-      (   aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
-      **~ bbbbbbbbbbbbbbbbbb
-      **~ cccccccccccccccccccccccccccccccccccccccccccccccccc
-      )
-    == 13

data/11-extensions/implicitparams.blt

@@ -8,9 +8,9 @@ func :: (?asd::Int) -> ()
 #test ImplicitParams 2
 {-# LANGUAGE ImplicitParams #-}
 func
-  :: ( ?asd
-       :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
-       -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+  :: (  ?asd
+     :: 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,33 +1051,3 @@ func = do
      block comment -}
   x <- readLine
   print x
-
-#test broken layout on do + operator + paren + do
-func = do
-  (wrapper $ do
-    stmt1
-    stmt2
-    )
-    `shouldReturn` thing
-
-#golden minimize parens basic test
--- brittany { lconfig_operatorParenthesisRefactorMode: PRMMinimize }
-func = func (abc) (def)
-#expected
--- brittany { lconfig_operatorParenthesisRefactorMode: PRMMinimize }
-func = func abc def
-
-#test wandering comment at end of datadecl
-data ReformatParenMode
-  = ReformatParenModeKeep  -- don't modify parens at all
-  | ReformatParenModeClean -- remove unnecessary parens
-  | ReformatParenModeAll   -- add superfluous parens everywhere
-
-#test empty do block error
-func = process $ do
-  it "some long description to fill this line" $ do
-  ( aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
-    + bbbbbbbbbbbbbbbbbb
-    + cccccccccccccccccccccccccccccccccccccccccccccccccc
-    )
-    `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.hs

@@ -12,36 +12,27 @@ module Language.Haskell.Brittany.Internal
   , TraceFunc(TraceFunc)
   , Splitting.splitModuleDecls
   , Splitting.extractDeclMap
-  , applyCPPTransformIfEnabledPre
-  , applyCPPTransformIfEnabledPost
-  , parsePrintModuleCommon
   )
 where
 
 import           Control.Monad.Trans.Except
-import           DataTreePrint                  ( printTreeWithCustom )
 import           Data.CZipWith
 import qualified Data.Text                     as Text
 import qualified Data.Text.Lazy                as TextL
-import qualified Data.Text.IO                  as Text.IO
 import qualified GHC.Driver.Session            as GHC
 import           GHC.Hs
 import qualified GHC.LanguageExtensions.Type   as GHC
-import qualified Language.Haskell.GHC.ExactPrint
-                                               as ExactPrint
 import qualified GHC.OldList                   as List
 import           Language.Haskell.Brittany.Internal.Config.Config
 import           Language.Haskell.Brittany.Internal.Config.InlineParsing
 import           Language.Haskell.Brittany.Internal.Config.Types
-import           Language.Haskell.Brittany.Internal.ToBriDocTools
+import           Language.Haskell.Brittany.Internal.S3_ToBriDocTools
 import           Language.Haskell.Brittany.Internal.Prelude
-import qualified Language.Haskell.Brittany.Internal.ParseExact
+import qualified Language.Haskell.Brittany.Internal.S1_Parsing
                                                as Parsing
-import qualified Language.Haskell.Brittany.Internal.SplitExactModule
+import qualified Language.Haskell.Brittany.Internal.S2_SplitModule
                                                as Splitting
-import           Language.Haskell.Brittany.Internal.Components.Obfuscation
-                                                ( obfuscate )
-import           Language.Haskell.Brittany.Internal.PerModule
+import           Language.Haskell.Brittany.Internal.StepOrchestrate
                                                 ( processModule )
 import           Language.Haskell.Brittany.Internal.Types
 import           Language.Haskell.Brittany.Internal.Utils
@@ -49,162 +40,6 @@ import Language.Haskell.Brittany.Internal.Config.Types.Instances1 ()
 
 
 
-applyCPPTransformIfEnabledPre :: Config -> String -> String
-applyCPPTransformIfEnabledPre config =
-  if hackAroundIncludes && not exactprintOnly
-    then List.intercalate "\n" . fmap hackF . lines'
-    else id
- where
-  -- the flag will do the following: insert a marker string
-  -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with
-  -- "#include" before processing (parsing) input; and remove that marker
-  -- string from the transformation output.
-  -- The flag is intentionally misspelled to prevent clashing with
-  -- inline-config stuff.
-  hackAroundIncludes =
-    config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack
-  exactprintOnly = viaGlobal || viaDebug
-   where
-    viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack
-    viaDebug =
-      config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack
-  hackF s = if "#include" `isPrefixOf` s
-    then "-- BRITANY_INCLUDE_HACK " ++ s
-    else s
-
-applyCPPTransformIfEnabledPost :: Config -> TextL.Text -> TextL.Text
-applyCPPTransformIfEnabledPost config =
-  if hackAroundIncludes && not exactprintOnly
-    then
-      TextL.intercalate (TextL.pack "\n")
-      . map hackF
-      . TextL.splitOn (TextL.pack "\n")
-    else id
- where
-  hackAroundIncludes =
-    config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack
-  exactprintOnly = viaGlobal || viaDebug
-   where
-    viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack
-    viaDebug =
-      config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack
-  hackF s = fromMaybe s
-    $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
-
-parsePrintModuleCommon
-  :: TraceFunc
-  -> Config
-  -> Either FilePath String
-  -> IO ()
-  -> IO (Either [BrittanyError] ([BrittanyError], Text, IO Bool))
-parsePrintModuleCommon traceFunc config inputE cppWarnAction = runExceptT $ do
-  let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
-  let cppMode    = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack
-  let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
-        then case cppMode of
-          CPPModeAbort  -> pure $ Left "Encountered -XCPP. Aborting."
-          CPPModeWarn   -> cppWarnAction $> Right True
-          CPPModeNowarn -> pure $ Right True
-        else pure $ Right False
-  (parseResult, originalContentAct) <- case inputE of
-    Left p -> liftIO $ do
-      parseRes <- Parsing.parseModule ghcOptions p cppCheckFunc
-      pure (parseRes, Text.IO.readFile p)
-      -- The above means we read the file twice, but the
-      -- GHC API does not really expose the source it
-      -- read. Should be in cache still anyways.
-      --
-      -- We do not use TextL.IO.readFile because lazy IO is evil.
-      -- (not identical -> read is not finished ->
-      -- handle still open -> write below crashes - evil.)
-    Right inputString -> do
-      parseRes <- liftIO
-        $ Parsing.parseModuleFromString
-          ghcOptions
-          "stdin"
-          cppCheckFunc
-          (applyCPPTransformIfEnabledPre config inputString)
-      pure (parseRes, pure $ Text.pack inputString)
-  (parsedSource, hasCPP) <- case parseResult of
-    Left  err -> throwE [ErrorInput err]
-    Right x   -> pure x
-  when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do
-    let val = printTreeWithCustom 160 customLayouterF parsedSource
-    liftIO $ useTraceFunc traceFunc ("---- ast ----\n" ++ show val)
-  let moduleElementList = Splitting.splitModuleDecls parsedSource
-  (inlineConf, perItemConf) <-
-    mapExceptT (fmap $ bimap (\(a, b) -> [ErrorMacroConfig a b]) id)
-    $ extractCommentConfigs (useTraceFunc traceFunc)
-                            (Splitting.extractDeclMap parsedSource)
-                            moduleElementList
-  let moduleConfig      = cZipWith fromOptionIdentity config inlineConf
-  let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack
-  let exactprintOnly = viaGlobal || viaDebug
-       where
-        viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack
-        viaDebug =
-          config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack
-  let omitCheck =
-        moduleConfig
-          & _conf_errorHandling
-          & _econf_omit_output_valid_check
-          & confUnpack
-  if
-    | disableFormatting -> do
-      originalContents <- liftIO $ originalContentAct
-      pure ([], originalContents, pure False)
-    | exactprintOnly -> do
-      let r = Text.pack $ ExactPrint.exactPrint parsedSource
-      pure
-        ( []
-        , r
-        , do
-            originalContents <- originalContentAct
-            pure $ originalContents /= r
-        )
-    | otherwise -> do
-      let
-        applyObfuscateIfEnabled =
-          if moduleConfig & _conf_obfuscate & confUnpack
-            then lift . obfuscate
-            else pure
-      (errsWarns, outRaw) <- if hasCPP || omitCheck
-        then lift
-          $ processModule traceFunc moduleConfig perItemConf moduleElementList
-        else lift
-          $ pPrintModuleAndCheck traceFunc
-                                 moduleConfig
-                                 perItemConf
-                                 moduleElementList
-      outputText <- applyObfuscateIfEnabled
-        (TextL.toStrict $ applyCPPTransformIfEnabledPost config outRaw)
-      let
-        hasErrors = \case
-          ErrorInput{} -> True
-          LayoutWarning{} ->
-            moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack
-          ErrorOutputCheck{}    -> True
-          ErrorUnusedComment{}  -> True
-          ErrorUnusedComments{} -> True
-          ErrorUnknownNode{}    -> True
-          ErrorMacroConfig{}    -> True
-        outputOnErrs =
-          config
-            & _conf_errorHandling
-            & _econf_produceOutputOnErrors
-            & confUnpack
-      if any hasErrors errsWarns && not outputOnErrs
-        then throwE $ errsWarns
-        else pure
-          $ ( errsWarns
-            , outputText
-            , do
-                originalContents <- liftIO $ originalContentAct
-                pure $ originalContents /= outputText
-            )
-
-  -- pure $ _ (parsed, hasCPP, originalContentAct)
-
 -- | Exposes the transformation in an pseudo-pure fashion. The signature
 -- contains `IO` due to the GHC API not exposing a pure parsing function, but
 -- there should be no observable effects.
@@ -221,12 +56,84 @@ parsePrintModule
 parsePrintModule traceFunc configWithDebugs inputText = runExceptT $ do
   let config =
         configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig }
-  (_errsWarns, output, _) <- ExceptT $ liftIO $ parsePrintModuleCommon
-    traceFunc
-    config
-    (Right $ Text.unpack inputText)
-    (pure ())
-  pure output
+  let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
+  let config_pp  = config & _conf_preprocessor
+  let cppMode    = config_pp & _ppconf_CPPMode & confUnpack
+  let hackAroundIncludes =
+        config_pp & _ppconf_hackAroundIncludes & confUnpack
+  (parsedSource, hasCPP) <- do
+    let hackF s = if "#include" `isPrefixOf` s
+          then "-- BRITANY_INCLUDE_HACK " ++ s
+          else s
+    let hackTransform = if hackAroundIncludes
+          then List.intercalate "\n" . fmap hackF . lines'
+          else id
+    let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
+          then case cppMode of
+            CPPModeAbort  -> return $ Left "Encountered -XCPP. Aborting."
+            CPPModeWarn   -> return $ Right True
+            CPPModeNowarn -> return $ Right True
+          else return $ Right False
+    parseResult <- lift $ Parsing.parseModuleFromString
+      ghcOptions
+      "stdin"
+      cppCheckFunc
+      (hackTransform $ Text.unpack inputText)
+    case parseResult of
+      Left  err -> throwE [ErrorInput err]
+      Right x   -> pure x
+  let moduleElementList = Splitting.splitModuleDecls parsedSource
+  (inlineConf, perItemConf) <-
+    mapExceptT (fmap $ bimap (\(a, b) -> [ErrorMacroConfig a b]) id)
+      $ extractCommentConfigs
+        (useTraceFunc traceFunc)
+        (Splitting.extractDeclMap parsedSource)
+        moduleElementList
+  let moduleConfig = cZipWith fromOptionIdentity config inlineConf
+  let disableFormatting =
+        moduleConfig & _conf_disable_formatting & confUnpack
+  if disableFormatting
+    then do
+      return inputText
+    else do
+      (errsWarns, outputTextL) <- do
+        let omitCheck =
+              moduleConfig
+                & _conf_errorHandling
+                & _econf_omit_output_valid_check
+                & confUnpack
+        (ews, outRaw) <- if hasCPP || omitCheck
+          then lift
+            $ processModule traceFunc moduleConfig perItemConf moduleElementList
+          else lift $ pPrintModuleAndCheck traceFunc
+                                           moduleConfig
+                                           perItemConf
+                                           moduleElementList
+        let hackF s = fromMaybe s
+              $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
+        pure $ if hackAroundIncludes
+          then
+            ( ews
+            , TextL.intercalate (TextL.pack "\n")
+            $   hackF
+            <$> TextL.splitOn (TextL.pack "\n") outRaw
+            )
+          else (ews, outRaw)
+      let customErrOrder ErrorInput{}          = 5
+          customErrOrder LayoutWarning{}       = 0 :: Int
+          customErrOrder ErrorOutputCheck{}    = 1
+          customErrOrder ErrorUnusedComment{}  = 2
+          customErrOrder ErrorUnusedComments{} = 3
+          customErrOrder ErrorUnknownNode{}    = 4
+          customErrOrder ErrorMacroConfig{}    = 6
+      let hasErrors =
+            if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack
+              then not $ null errsWarns
+              else 0 < maximum (-1 : fmap customErrOrder errsWarns)
+      if hasErrors
+        then throwE $ errsWarns
+        else pure $ TextL.toStrict outputTextL
+
 
 
 -- | Additionally checks that the output compiles again, appending an error

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

@@ -32,8 +32,8 @@ displayOpTree = \case
     ++ " ["
     ++ intercalate
          ","
-         [ ("(" ++ showOp op ++ "," ++ displayOpTree x ++ ")") | (op, x) <- rs ]
-    ++ "])"
+         [ ("(" ++ showOp op ++ "," ++ show x ++ ")") | (op, (x, _)) <- rs ]
+    ++ "]"
     )
   OpKnown p _ _ fixity tree ops ->
     (  "OpKnown "
@@ -89,20 +89,7 @@ type Stack = [StackElem]
 
 balanceOpTree :: Bool -> OpTree -> ([BrittanyError], OpTree)
 balanceOpTree allowUnqualify = \case
-  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@OpLeaf{}  -> ([], x)
   x@OpKnown{} -> ([], x)
   x@(OpUnknown paren locO locC left rest) ->
     let (warns, balancedLeft) = balanceOpTree allowUnqualify left
@@ -122,7 +109,11 @@ balanceOpTree allowUnqualify = \case
  where
   -- singleton :: BriDocNumbered -> StackElem
   -- singleton x = StackElem (Fixity NoSourceText 99 InfixN) (OpLeaf x) []
-  go :: Stack -> [(BriDocNumbered, OpTree)] -> OpTree -> Either [String] OpTree
+  go
+    :: 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)
@@ -133,20 +124,24 @@ balanceOpTree allowUnqualify = \case
   go stack input@((opDoc, val) : inputR) c = case stack of
     [] -> do
       fxty <- docFixity opDoc
-      go [StackElem fxty [(c, opDoc)]] inputR val
+      go [StackElem fxty [(c, opDoc)]] inputR (OpLeaf 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 val
+        GT -> go (StackElem fxty [(c, opDoc)] : stack) inputR (OpLeaf 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) inputR val
+            go (StackElem fixityS ((c, opDoc) : cs) : stackR)
+               inputR
+               (OpLeaf val)
           (InfixL, InfixL) ->
-            go (StackElem fixityS ((c, opDoc) : cs) : stackR) inputR val
+            go (StackElem fixityS ((c, opDoc) : cs) : stackR)
+               inputR
+               (OpLeaf val)
           _ -> Left []
   docFixity :: BriDocNumbered -> Either [String] Fixity
   docFixity (_, x) = case x of
@@ -168,9 +163,9 @@ balanceOpTree allowUnqualify = \case
               mapAccumL (\op (nextE, nextOp) -> (nextOp, (op, nextE))) o1 rest
         in  list ++ [(finalOp, final)]
       )
-  known = OpKnown NoParen Nothing Nothing
+  known = OpKnown False Nothing Nothing
 
-addAllParens :: OpParenMode -> OpTree -> OpTree
+addAllParens :: Bool -> OpTree -> OpTree
 addAllParens topLevelParen = \case
   x@OpLeaf{}    -> x
   x@OpUnknown{} -> x
@@ -179,22 +174,16 @@ addAllParens topLevelParen = \case
             locO
             locC
             fixity
-            (addAllParens ParenWithSpace c)
-            [ (op, addAllParens ParenWithSpace tree) | (op, tree) <- cs ]
+            (addAllParens True c)
+            [ (op, addAllParens True tree) | (op, tree) <- cs ]
 
 remSuperfluousParens :: Int -> OpTree -> OpTree
 remSuperfluousParens outerFixity = \case
-  x@OpLeaf{}                 -> x
-  OpUnknown _ locO locC c [] -> OpUnknown NoParen locO locC c []
-  x@OpUnknown{}              -> x
+  x@OpLeaf{}    -> x
+  x@OpUnknown{} -> x
   OpKnown paren locO locC fixity c cs ->
     OpKnown
-      -- We do not support removing superfluous parens around
-      -- function types yet:
-      (if outerFixity > fixLevel fixity || fixLevel fixity < 0
-        then paren
-        else NoParen
-      )
+      (paren && outerFixity > fixLevel fixity)
       locO
       locC
       fixity
@@ -204,8 +193,6 @@ 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/PerDecl.hs

@@ -1,67 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE DataKinds #-}
-
-module Language.Haskell.Brittany.Internal.PerDecl
-  ( ppToplevelDecl
-  ) where
-
-import           Language.Haskell.Brittany.Internal.Prelude
-
-import qualified GHC
-import           GHC                            ( EpaCommentTok
-                                                , GenLocated(L)
-                                                , LHsDecl
-                                                , SrcSpanAnn'(SrcSpanAnn)
-                                                )
-
-import           Language.Haskell.Brittany.Internal.Config.Types
-import           Language.Haskell.Brittany.Internal.Config.Types.Instances2
-                                                ( )
-import           Language.Haskell.Brittany.Internal.ToBriDocTools
-import           Language.Haskell.Brittany.Internal.WriteBriDoc
-                                                ( ppBriDoc )
-import           Language.Haskell.Brittany.Internal.ToBriDoc.Decl
-import           Language.Haskell.Brittany.Internal.ToBriDoc.Comment
-import           Language.Haskell.Brittany.Internal.Types
-import           Language.Haskell.Brittany.Internal.ToBriDoc
-                                                ( layouters )
-
-
-
-ppToplevelDecl :: LHsDecl GhcPs -> [(Int, EpaCommentTok)] -> PPMLocal ()
-ppToplevelDecl decl immediateAfterComms = do
-  exactprintOnly <- mAsk <&> \declConfig ->
-    declConfig & _conf_roundtrip_exactprint_only & confUnpack
-  bd <- fmap fst $ if exactprintOnly
-    then briDocMToPPM layouters $ docSeq
-      (briDocByExactNoComment decl : map commentToDoc immediateAfterComms)
-    else do
-      let innerDoc = case decl of
-            L (SrcSpanAnn _ (GHC.RealSrcSpan s _)) _ ->
-              docFlushRemaining (GHC.srcSpanFile s) $ layoutDecl decl
-            _ -> layoutDecl decl
-      (r, errorCount) <- briDocMToPPM layouters $ docSeq
-        (innerDoc : map commentToDoc immediateAfterComms)
-      if errorCount == 0
-        then pure (r, 0)
-        else briDocMToPPM layouters $ briDocByExactNoComment decl
-  ppBriDoc bd False
-  let commCntIn = connectedCommentCount decl
-  commCntOut <- mGet
-  when (commCntIn /= commCntOut) $ if commCntOut < commCntIn
-    then mTell
-      [ ErrorUnusedComments decl
-                            (unCommentCounter commCntIn)
-                            (unCommentCounter commCntOut)
-      ]
-    else mTell
-      [ ErrorUnusedComments decl
-                            (unCommentCounter commCntIn)
-                            (unCommentCounter commCntOut)
-      ]
-      -- error
-      -- $  "internal brittany error: inconsistent comment count ("
-      -- ++ show commCntOut
-      -- ++ ">"
-      -- ++ show commCntIn
-      -- ++ ")!"

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

@@ -189,7 +189,7 @@ import Prelude as E
   , undefined
   , (||)
   )
-import System.IO as E (IO, hFlush, stdout, FilePath)
+import System.IO as E (IO, hFlush, stdout)
 import Text.Read as E (readMaybe)
 
 import qualified Data.Strict.Maybe as Strict

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

@@ -1,6 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 
-module Language.Haskell.Brittany.Internal.ParseExact
+module Language.Haskell.Brittany.Internal.S1_Parsing
   ( parseModule
   , parseModuleFromString
   )

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

@@ -1,11 +1,11 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
+-- TODO92
 
-module Language.Haskell.Brittany.Internal.SplitExactModule
+module Language.Haskell.Brittany.Internal.S2_SplitModule
   ( extractDeclMap
   , splitModuleDecls
   , splitModuleStart
-  , getDeclBindingNames
   ) where
 
 
@@ -15,7 +15,6 @@ import           Language.Haskell.Brittany.Internal.Prelude
 import qualified Data.Generics                 as SYB
 import qualified Data.List.Extra
 import qualified Data.Map                      as Map
-import qualified Data.Text                     as Text
 import qualified GHC
 import           GHC                            ( AddEpAnn(AddEpAnn)
                                                 , Anchor(Anchor)
@@ -48,21 +47,11 @@ import           GHC                            ( AddEpAnn(AddEpAnn)
                                                 , SrcSpanAnn'(SrcSpanAnn)
                                                 , anchor
                                                 , ideclName
-                                                , moduleName
                                                 , moduleNameString
                                                 , srcLocCol
                                                 , srcLocLine
                                                 , unLoc
                                                 )
-import           GHC.Types.Name                 ( getOccString )
-import           GHC.Types.Name.Occurrence      ( occNameString )
-import           GHC.Types.Name.Reader          ( RdrName
-                                                  ( Exact
-                                                  , Orig
-                                                  , Qual
-                                                  , Unqual
-                                                  )
-                                                )
 import qualified GHC.OldList                   as List
 import           GHC.Parser.Annotation          ( DeltaPos
                                                   ( DifferentLine
@@ -84,6 +73,7 @@ import qualified Control.Monad.Trans.Writer.Strict
 import           Language.Haskell.Brittany.Internal.Components.BriDoc
 import           Language.Haskell.Brittany.Internal.ToBriDoc.Module
 import           Language.Haskell.Brittany.Internal.Types
+import           Language.Haskell.Brittany.Internal.Util.AST
 
 
 
@@ -437,19 +427,3 @@ sortCommentedImports =
       (l@SamelineComment{} : rest) -> Left l : Right (reverse acc) : go [] rest
       (ImportStatement r   : rest) -> go (r : acc) rest
       []                           -> [Right (reverse acc)]
-
-rdrNameToText :: RdrName -> Text
--- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr
-rdrNameToText (Unqual occname) = Text.pack $ occNameString occname
-rdrNameToText (Qual mname occname) =
-  Text.pack $ moduleNameString mname ++ "." ++ occNameString occname
-rdrNameToText (Orig modul occname) =
-  Text.pack $ moduleNameString (moduleName modul) ++ occNameString occname
-rdrNameToText (Exact name) = Text.pack $ getOccString name
-
-getDeclBindingNames :: GHC.LHsDecl GhcPs -> [String]
-getDeclBindingNames (L _ decl) = case decl of
-  GHC.SigD _ (GHC.TypeSig _ ns _) ->
-    ns <&> \(L _ n) -> Text.unpack (rdrNameToText n)
-  GHC.ValD _ (GHC.FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n]
-  _ -> []

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

@@ -1,7 +1,7 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
-module Language.Haskell.Brittany.Internal.ToBriDocTools where
+module Language.Haskell.Brittany.Internal.S3_ToBriDocTools where
 
 import qualified Control.Monad.Writer.Strict   as Writer
 import qualified Data.Char                     as Char
@@ -795,8 +795,7 @@ docHandleListElemComms layouter e = case obtainListElemStartCommaLocs e of
 docHandleListElemCommsProperPost
   :: (LocatedA ast -> ToBriDocM BriDocNumbered)
   -> [LocatedA ast]
-  -> ToBriDocM
-       [(Maybe GHC.RealSrcLoc, LocatedA ast, ToBriDocM BriDocNumbered)]
+  -> ToBriDocM [(Maybe GHC.RealSrcLoc, ToBriDocM BriDocNumbered)]
 docHandleListElemCommsProperPost layouter es = case es of
   []          -> pure []
   (e1 : rest) -> case obtainListElemStartCommaLocs e1 of
@@ -804,8 +803,7 @@ docHandleListElemCommsProperPost layouter es = case es of
       res <- go posComma rest
       pure
         $ ( Nothing
-          , e1
-          , docHandleComms posStart $ layouter e1
+          , docFlushCommsPost True e1 $ docHandleComms posStart $ layouter e1
           )
         : res
  where
@@ -815,8 +813,7 @@ docHandleListElemCommsProperPost layouter es = case es of
       res <- go posComma rest
       pure
         $ ( intoComma
-          , e1
-          , docHandleComms posStart $ layouter e1
+          , docFlushCommsPost True e1 $ docHandleComms posStart $ layouter e1
           )
         : res
 

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

@@ -1,6 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 
-module Language.Haskell.Brittany.Internal.WriteBriDoc
+module Language.Haskell.Brittany.Internal.S4_WriteBriDoc
   ( ppBriDoc
   )
 where

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

@@ -1,7 +1,7 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE DataKinds #-}
 
-module Language.Haskell.Brittany.Internal.PerModule
+module Language.Haskell.Brittany.Internal.StepOrchestrate
   ( processModule
   ) where
 
@@ -24,6 +24,7 @@ import           GHC                            ( EpaComment(EpaComment)
                                                 , GenLocated(L)
                                                 , HsModule(HsModule)
                                                 , LHsDecl
+                                                , SrcSpanAnn'(SrcSpanAnn)
                                                 )
 import qualified GHC.Types.SrcLoc              as GHC
 import qualified GHC.OldList                   as List
@@ -35,23 +36,19 @@ import           Language.Haskell.Brittany.Internal.Components.BriDoc
 import           Language.Haskell.Brittany.Internal.Config.Types
 import           Language.Haskell.Brittany.Internal.Config.Types.Instances2
                                                 ( )
-import           Language.Haskell.Brittany.Internal.SplitExactModule
-                                                ( getDeclBindingNames
-                                                , splitModuleStart
-                                                )
-import           Language.Haskell.Brittany.Internal.ToBriDocTools
-import           Language.Haskell.Brittany.Internal.WriteBriDoc
+import           Language.Haskell.Brittany.Internal.S2_SplitModule
+                                                ( splitModuleStart )
+import           Language.Haskell.Brittany.Internal.S3_ToBriDocTools
+import           Language.Haskell.Brittany.Internal.S4_WriteBriDoc
                                                 ( ppBriDoc )
-import           Language.Haskell.Brittany.Internal.ToBriDoc.Comment
-                                                ( commentToDoc )
+import           Language.Haskell.Brittany.Internal.ToBriDoc.Decl
 import           Language.Haskell.Brittany.Internal.ToBriDoc.Import
 import           Language.Haskell.Brittany.Internal.ToBriDoc.Module
 import           Language.Haskell.Brittany.Internal.Types
+import           Language.Haskell.Brittany.Internal.Util.AST
 import           Language.Haskell.Brittany.Internal.Utils
 import           Language.Haskell.Brittany.Internal.ToBriDoc
                                                 ( layouters )
-import           Language.Haskell.Brittany.Internal.PerDecl
-                                                ( ppToplevelDecl )
 
 
 
@@ -185,6 +182,18 @@ processModule traceFunc conf inlineConf moduleElems = do
       -- mTell $ TextL.Builder.fromString ("whitespace " ++ show dp)
       ppmMoveToExactLoc dp
 
+commentToDoc :: (Int, EpaCommentTok) -> ToBriDocM BriDocNumbered
+commentToDoc (indent, c) = case c of
+  GHC.EpaDocCommentNext  str -> docLitS (replicate indent ' ' ++ str)
+  GHC.EpaDocCommentPrev  str -> docLitS (replicate indent ' ' ++ str)
+  GHC.EpaDocCommentNamed str -> docLitS (replicate indent ' ' ++ str)
+  GHC.EpaDocSection _ str    -> docLitS (replicate indent ' ' ++ str)
+  GHC.EpaDocOptions   str    -> docLitS (replicate indent ' ' ++ str)
+  GHC.EpaLineComment  str    -> docLitS (replicate indent ' ' ++ str)
+  GHC.EpaBlockComment str    -> docLitS (replicate indent ' ' ++ str)
+  GHC.EpaEofComment          -> docEmpty
+
+
 -- Prints the information associated with the module annotation
 -- This includes the imports
 -- This returns a `Maybe` because it only produces a BriDocNumbered if
@@ -222,4 +231,41 @@ getDeclConfig config inlineConf decl = cZipWith fromOptionIdentity config
     GHC.RealSrcSpan x _ -> Map.lookup x $ _icd_perAnchor inlineConf
     GHC.UnhelpfulSpan{} -> Nothing
 
+ppToplevelDecl :: LHsDecl GhcPs -> [(Int, EpaCommentTok)] -> PPMLocal ()
+ppToplevelDecl decl immediateAfterComms = do
+  exactprintOnly <- mAsk <&> \declConfig ->
+    declConfig & _conf_roundtrip_exactprint_only & confUnpack
+  bd <- fmap fst $ if exactprintOnly
+    then briDocMToPPM layouters $ docSeq
+      (briDocByExactNoComment decl : map commentToDoc immediateAfterComms)
+    else do
+      let innerDoc = case decl of
+            L (SrcSpanAnn _ (GHC.RealSrcSpan s _)) _ ->
+              docFlushRemaining (GHC.srcSpanFile s) $ layoutDecl decl
+            _ -> layoutDecl decl
+      (r, errorCount) <- briDocMToPPM layouters $ docSeq
+        (innerDoc : map commentToDoc immediateAfterComms)
+      if errorCount == 0
+        then pure (r, 0)
+        else briDocMToPPM layouters $ briDocByExactNoComment decl
+  ppBriDoc bd False
+  let commCntIn = connectedCommentCount decl
+  commCntOut <- mGet
+  when (commCntIn /= commCntOut) $ if commCntOut < commCntIn
+    then mTell
+      [ ErrorUnusedComments decl
+                            (unCommentCounter commCntIn)
+                            (unCommentCounter commCntOut)
+      ]
+    else mTell
+      [ ErrorUnusedComments decl
+                            (unCommentCounter commCntIn)
+                            (unCommentCounter commCntOut)
+      ]
+      -- error
+      -- $  "internal brittany error: inconsistent comment count ("
+      -- ++ show commCntOut
+      -- ++ ">"
+      -- ++ show commCntIn
+      -- ++ ")!"
 

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

@@ -1,39 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Language.Haskell.Brittany.Internal.ToBriDoc.Comment
-  ( commentToDoc
-  ) where
-
-import           Language.Haskell.Brittany.Internal.Prelude
-
-import           GHC                            ( EpaCommentTok
-                                                  ( EpaBlockComment
-                                                  , EpaDocCommentNamed
-                                                  , EpaDocCommentNext
-                                                  , EpaDocCommentPrev
-                                                  , EpaDocOptions
-                                                  , EpaDocSection
-                                                  , EpaEofComment
-                                                  , EpaLineComment
-                                                  )
-                                                )
-import           Language.Haskell.Brittany.Internal.Types
-import           Language.Haskell.Brittany.Internal.Components.BriDoc
-import           Language.Haskell.Brittany.Internal.ToBriDocTools
-
-
-
-commentToDoc :: (Int, EpaCommentTok) -> ToBriDocM BriDocNumbered
-commentToDoc (indent, c) = case c of
-  GHC.EpaDocCommentNext  str -> handle str
-  GHC.EpaDocCommentPrev  str -> handle str
-  GHC.EpaDocCommentNamed str -> handle str
-  GHC.EpaDocSection _ str    -> handle str
-  GHC.EpaDocOptions   str    -> handle str
-  GHC.EpaLineComment  str    -> handle str
-  GHC.EpaBlockComment str    -> handle str
-  GHC.EpaEofComment          -> docEmpty
- where
-  handle str = if indent == 0
-    then docLitS str
-    else docSeq [docSeparator, docLitS $ (replicate (indent - 1) ' ') ++ str ]

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

@@ -7,7 +7,7 @@ import GHC (GenLocated(L))
 import GHC.Hs
 import qualified GHC.OldList as List
 import Language.Haskell.Brittany.Internal.Config.Types
-import Language.Haskell.Brittany.Internal.ToBriDocTools
+import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
 import Language.Haskell.Brittany.Internal.Prelude
 import Language.Haskell.Brittany.Internal.Types
 import Language.Haskell.Brittany.Internal.Components.BriDoc
@@ -293,9 +293,9 @@ layoutConDecl (prefix, L _ con) = case con of
 layoutHsTyPats
   :: [LHsTypeArg GhcPs] -> [ToBriDocM BriDocNumbered]
 layoutHsTyPats pats = pats <&> \case
-  HsValArg tm -> callLayouter2 layout_type False tm
+  HsValArg tm -> callLayouter layout_type tm
   HsTypeArg _l ty ->
-    docSeq [docLit $ Text.pack "@", callLayouter2 layout_type False ty]
+    docSeq [docLit $ Text.pack "@", callLayouter layout_type 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 [callLayouter2 layout_type False t, docSeparator, docLitS "=>", docSeparator]
+  docSeq [callLayouter layout_type t, docSeparator, docLitS "=>", docSeparator]
 createContextDoc (t1 : tR) = do
-  t1Doc <- shareDoc $ callLayouter2 layout_type False t1
-  tRDocs <- tR `forM` (shareDoc . callLayouter2 layout_type False)
+  t1Doc <- shareDoc $ callLayouter layout_type t1
+  tRDocs <- tR `forM` (shareDoc . callLayouter layout_type)
   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 $ callLayouter2 layout_type False kind
+      d <- shareDoc $ callLayouter layout_type 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
-        <&> callLayouter2 layout_type False
+        <&> callLayouter layout_type
         ]
       leftIndented =
         docSetParSpacing
           . docAddBaseY BrIndentRegular
           . docPar (docLit consNameStr)
           . docLines
-          $ callLayouter2 layout_type False
+          $ callLayouter layout_type
           <$> fmap hsScaledThing args
       multiAppended = docSeq
         [ docLit consNameStr
         , docSeparator
         , docSetBaseY
           $ docLines
-          $ callLayouter2 layout_type False <$> fmap hsScaledThing args
+          $ callLayouter layout_type <$> fmap hsScaledThing args
         ]
       multiIndented = docSetBaseY $ docAddBaseY BrIndentRegular $ docPar
         (docLit consNameStr)
-        (docLines $ callLayouter2 layout_type False <$> fmap hsScaledThing args)
+        (docLines $ callLayouter layout_type <$> 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
-    [ callLayouter2 layout_type False $ hsScaledThing arg1
+    [ callLayouter layout_type $ hsScaledThing arg1
     , docSeparator
     , docLit consNameStr
     , docSeparator
-    , callLayouter2 layout_type False $ hsScaledThing arg2
+    , callLayouter layout_type $ hsScaledThing arg2
     ]
  where
   mkFieldDocs
@@ -551,10 +551,7 @@ createNamesAndTypeDoc lField@(L _ (ConDeclField epAnn names t _)) =
             L _ (FieldOcc _ fieldName) ->
               docLit =<< lrdrNameToTextAnn fieldName
         ]
-  , docFlushCommsPost
-      True
-      posComma
-      (callLayouter2 layout_type (hasAnyCommentsBelow epAnn) t)
+  , docFlushCommsPost True posComma (callLayouter layout_type t)
   )
  where
   (posStart, posComma) = obtainListElemStartCommaLocs lField

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

@@ -21,7 +21,7 @@ import GHC.Types.SrcLoc (Located, getLoc, unLoc)
 import qualified GHC
 import qualified GHC.Types.SrcLoc as GHC
 import Language.Haskell.Brittany.Internal.Config.Types
-import Language.Haskell.Brittany.Internal.ToBriDocTools
+import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
 import Language.Haskell.Brittany.Internal.Prelude
 import Language.Haskell.Brittany.Internal.Types
 import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
@@ -806,7 +806,7 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of
                  ]
               ++ fmap (layoutTyVarBndr True) (hsq_explicit vars)
       sharedLhs <- shareDoc $ id lhs
-      typeDoc   <- shareDoc $ callLayouter2 layout_type False typ
+      typeDoc   <- shareDoc $ callLayouter layout_type 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 $ callLayouter2 layout_type False kind
+         , docForceSingleline $ callLayouter layout_type kind
          , docLit $ Text.pack ")"
          ]
 
@@ -883,7 +883,7 @@ layoutTyFamInstDecl inClass outerNode tfid = do
     -- <$> hasAnyRegularCommentsConnected outerNode
     -- <*> hasAnyRegularCommentsRest innerNode
   let hasComments = hasAnyCommentsConnected outerNode
-  typeDoc <- shareDoc $ callLayouter2 layout_type False typ
+  typeDoc <- shareDoc $ callLayouter layout_type typ
   layoutLhsAndType hasComments lhs (docHandleComms posEqual $ docLit $ Text.pack "=") 1 typeDoc
 
 

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

@@ -23,7 +23,7 @@ import qualified GHC.Types.SrcLoc              as GHC
 import           Language.Haskell.Brittany.Internal.Components.BriDoc
 import           Language.Haskell.Brittany.Internal.Config.Types
 import           Language.Haskell.Brittany.Internal.Prelude
-import           Language.Haskell.Brittany.Internal.ToBriDocTools
+import           Language.Haskell.Brittany.Internal.S3_ToBriDocTools
 import           Language.Haskell.Brittany.Internal.Types
 import           Language.Haskell.Brittany.Internal.Utils
 
@@ -214,7 +214,7 @@ layoutExpr lexpr@(L _ expr) = do
           headDoc
           (docNonBottomSpacing $ docLines paramDocs)
     HsAppType _ exp1 (HsWC _ ty1) -> do
-      t <- shareDoc $ callLayouter2 layout_type False ty1
+      t <- shareDoc $ callLayouter layout_type ty1
       e <- shareDoc $ callLayouter layout_expr exp1
       docAlt
         [ docSeq
@@ -238,16 +238,52 @@ layoutExpr lexpr@(L _ expr) = do
       --         || hasAnyCommentsConnected expOp
       layouters <- mAsk
       treeAndHasComms <-
-        layout_gatherOpTreeE layouters NoParen False id Nothing Nothing [] lexpr
+        layout_gatherOpTreeE layouters False False id Nothing Nothing [] lexpr
       layout_opTree layouters treeAndHasComms
     NegApp _ op _ -> do
       opDoc <- shareDoc $ layoutExpr op
       docSeq [docLit $ Text.pack "-", opDoc]
-    HsPar _epAnn _inner -> do
+    HsPar _epAnn (L _ (OpApp _topEpAnn _expLeft _expOp _)) -> 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 NoParen False id Nothing Nothing [] lexpr
+        layout_gatherOpTreeE layouters False 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
@@ -613,17 +649,6 @@ layoutExpr lexpr@(L _ expr) = do
           , expDoc1
           ]
       -- docSeq [appSep $ docLit "let in", expDoc1]
-    HsDo epAnn stmtCtx (L (SrcSpanAnn stmtEpAnn _) []) ->
-      case stmtCtx of
-        DoExpr _ ->
-          docHandleComms epAnn $ docHandleComms stmtEpAnn $ docLitS "do"
-        MDoExpr _ ->
-          docHandleComms epAnn $ docHandleComms stmtEpAnn $ docLitS "mdo"
-        ListComp ->
-          error "brittany internal error: ListCompo with null statements"
-        MonadComp ->
-          error "brittany internal error: ListCompo with null statements"
-        _ -> unknownNodeError "HsDo{} unknown stmtCtx" lexpr
     HsDo epAnn stmtCtx (L (SrcSpanAnn stmtEpAnn _) stmts) ->
       docHandleComms epAnn $ do
         case stmtCtx of
@@ -710,23 +735,17 @@ layoutExpr lexpr@(L _ expr) = do
       let hasComments = hasAnyCommentsBelow lexpr
       case splitFirstLast elemDocs of
         FirstLastEmpty       -> docSeq [docLit $ Text.pack "[", closeDoc]
-        FirstLastSingleton (_, ast, e) -> docAlt
+        FirstLastSingleton (_, e) -> docAlt
           [ docSeq [openDoc, docForceSingleline e, closeDoc]
           , docSetBaseY $ docLines
-            [ docSeq
-              [ openDoc
-              , docSeparator
-              , docSetBaseY $ docFlushCommsPost True ast e
-              ]
-            , closeDoc
-            ]
+            [docSeq [openDoc, docSeparator, docSetBaseY $ e], closeDoc]
           ]
-        FirstLast (_, _, e1) ems (finalCommaPos, _, eN) -> runFilteredAlternative $ do
+        FirstLast (_, e1) ems (finalCommaPos, eN) -> runFilteredAlternative $ do
           addAlternativeCond (not hasComments)
             $  docSeq
             $  [openDoc, docForceSingleline e1]
             ++ [ x
-               | (commaPos, _, e) <- ems
+               | (commaPos, e) <- ems
                , x <- [docHandleComms commaPos docCommaSep, docForceSingleline e]
                ]
             ++ [ docHandleComms finalCommaPos docCommaSep
@@ -734,12 +753,8 @@ layoutExpr lexpr@(L _ expr) = do
                , closeDoc]
           addAlternative
             $ let start  = docCols ColList [appSep $ openDoc, e1]
-                  linesM = ems <&> \(p, ast, d) ->
-                    docCols
-                      ColList
-                      [ docHandleComms p docCommaSep
-                      , docFlushCommsPost True ast $ d
-                      ]
+                  linesM = ems <&> \(p, d) ->
+                    docCols ColList [docHandleComms p docCommaSep, d]
                   lineN  = docCols ColList
                     [docHandleComms finalCommaPos $ docCommaSep, eN]
               in  docSetBaseY

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

@@ -17,7 +17,7 @@ import qualified Data.Data
 
 import           Language.Haskell.Brittany.Internal.Components.BriDoc
 import           Language.Haskell.Brittany.Internal.Prelude
-import           Language.Haskell.Brittany.Internal.ToBriDocTools
+import           Language.Haskell.Brittany.Internal.S3_ToBriDocTools
 import           Language.Haskell.Brittany.Internal.Types
 import           Language.Haskell.Brittany.Internal.Utils
 

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

@@ -13,7 +13,7 @@ import GHC.Types.Basic
 import GHC.Types.SourceText(SourceText(SourceText, NoSourceText), sl_st)
 import GHC.Unit.Types (IsBootInterface(..))
 import Language.Haskell.Brittany.Internal.Config.Types
-import Language.Haskell.Brittany.Internal.ToBriDocTools
+import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
 import Language.Haskell.Brittany.Internal.Prelude
 import Language.Haskell.Brittany.Internal.Types
 import Language.Haskell.Brittany.Internal.Components.BriDoc

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

@@ -13,7 +13,7 @@ import           GHC.Hs
 import           Language.Haskell.Brittany.Internal.Components.BriDoc
 import           Language.Haskell.Brittany.Internal.Config.Types
 import           Language.Haskell.Brittany.Internal.Prelude
-import           Language.Haskell.Brittany.Internal.ToBriDocTools
+import           Language.Haskell.Brittany.Internal.S3_ToBriDocTools
 import           Language.Haskell.Brittany.Internal.Types
 
 

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

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

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

@@ -10,7 +10,7 @@ import GHC (GenLocated(L), ol_val)
 import GHC.Hs
 import qualified GHC.OldList as List
 import GHC.Types.Basic
-import Language.Haskell.Brittany.Internal.ToBriDocTools
+import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
 import Language.Haskell.Brittany.Internal.Prelude
 import Language.Haskell.Brittany.Internal.Types
 import Language.Haskell.Brittany.Internal.Components.BriDoc
@@ -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 $ callLayouter2 layout_type False ty1
+    tyDoc <- shareDoc $ callLayouter layout_type ty1
     case Seq.viewr patDocs of
       Seq.EmptyR -> error "cannot happen ljoiuxoasdcoviuasd"
       xR Seq.:> xN -> do

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

@@ -8,7 +8,7 @@ import qualified Data.Text as Text
 import GHC (GenLocated(L))
 import GHC.Hs
 import Language.Haskell.Brittany.Internal.Config.Types
-import Language.Haskell.Brittany.Internal.ToBriDocTools
+import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
 import Language.Haskell.Brittany.Internal.Prelude
 import Language.Haskell.Brittany.Internal.Types
 import Language.Haskell.Brittany.Internal.Components.BriDoc

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

@@ -11,10 +11,7 @@ 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.ToBriDocTools
+import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
 import Language.Haskell.Brittany.Internal.Prelude
 import Language.Haskell.Brittany.Internal.Types
 import Language.Haskell.Brittany.Internal.Components.BriDoc
@@ -26,56 +23,55 @@ import Language.Haskell.Brittany.Internal.Utils
 layoutSigType :: ToBriDoc HsSigType
 -- TODO92 we ignore an ann here
 layoutSigType (L _ (HsSig _ outerVarBind typ)) = case outerVarBind of
-  HsOuterImplicit _       -> callLayouter2 layout_type False typ
+  HsOuterImplicit _ -> callLayouter layout_type typ
   HsOuterExplicit _ bndrs -> do
-    (headPart, restParts) <-
-      splitHsForallTypeFromBinders (map withoutSpecificity bndrs) typ
-    layoutSplitArrowType (headPart, restParts) (hasAnyCommentsBelow typ)
+    parts <- splitHsForallTypeFromBinders (map withoutSpecificity bndrs) typ
+    joinSplitArrowType (hasAnyCommentsBelow typ) parts
 
 splitArrowType
   :: LHsType GhcPs
-  -> ToBriDocM (OpTree, [(BriDocNumbered, OpTree)])
+  -> ToBriDocM
+       (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
-      Nothing                            -> pure (id, [])
+    (wrapCtx, cntxtDocs) <- case ctxMay of
+      Nothing         -> pure (id, [])
       Just (L (SrcSpanAnn epAnn _) ctxs) -> do
-        let
-          wrap = case epAnn of
-            EpAnn _ (AnnContext (Just (_, loc)) _ _) _ ->
-              docFlushCommsPost False (Just $ epaLocationRealSrcSpanStart loc)
-                . docHandleComms epAnn
-            _ -> docHandleComms epAnn
-        x <- ctxs `forM` (shareDoc . layoutType False)
+        let wrap = case epAnn of
+              EpAnn _ (AnnContext (Just (_, loc)) _ _) _ ->
+                docFlushCommsPost False (Just $ epaLocationRealSrcSpanStart loc)
+                  . docHandleComms epAnn
+              _ -> docHandleComms epAnn
+        x <- ctxs `forM` (shareDoc . layoutType)
         pure (wrap, x)
-    outerHead <- wrapCtx $ case cntxtDocs of
-      []   -> docLit $ Text.pack "()"
-      [x]  -> x
-      docs -> docAlt
-        [ let
-              open  = docLit $ Text.pack "("
-              close = docLit $ Text.pack ")"
-              list  = List.intersperse docCommaSep $ docForceSingleline <$> docs
-          in  docSeq ([open] ++ list ++ [close])
-        , let
-            open =
-              docCols
-                ColTyOpPrefix
-                [docParenLSep
-                             , docAddBaseY (BrIndentSpecial 2) $ head docs
-                                                                          ]
-            close = docLit $ Text.pack ")"
-            list  = List.tail docs <&> \cntxtDoc ->
-              docCols ColTyOpPrefix
+    pure
+      $ ( wrapCtx $ case cntxtDocs of
+            []   -> docLit $ Text.pack "()"
+            [x]  -> x
+            docs -> docAlt
+              [ let
+                  open  = docLit $ Text.pack "("
+                  close = docLit $ Text.pack ")"
+                  list =
+                    List.intersperse docCommaSep $ docForceSingleline <$> docs
+                in
+                  docSeq ([open] ++ list ++ [close])
+              , let open = docCols
+                      ColTyOpPrefix
+                      [ docParenLSep
+                      , docAddBaseY (BrIndentSpecial 2) $ head docs
+                      ]
+                    close = docLit $ Text.pack ")"
+                    list  = List.tail docs <&> \cntxtDoc -> docCols
+                      ColTyOpPrefix
                       [docCommaSep, docAddBaseY (BrIndentSpecial 2) cntxtDoc]
-          in
-            docPar open $ docLines $ list ++ [close]
-        ]
-    arrowDoc <- docLitS "=>"
-    pure (OpLeaf outerHead, (arrowDoc, innerHead) : innerBody)
+                in  docPar open $ docLines $ list ++ [close]
+              ]
+        , (("=>", innerHead) : innerBody)
+        )
   HsFunTy epAnn _ typ1 typ2 -> do
     (typ1Doc, (innerHead, innerBody)) <- do
       let
@@ -93,92 +89,71 @@ splitArrowType ltype@(L _ typ) = case typ of
           EpAnn _ AddLollyAnnU{} _ ->
             error "brittany internal error: HsFunTy EpAnn"
           EpAnnNotUsed -> id
-      typ1Doc   <- docHandleComms epAnn $ wrapper $ layoutType False typ1
+      typ1Doc   <- docHandleComms epAnn $ wrapper $ layoutType typ1
       typ2Tuple <- splitArrowType typ2
       pure (typ1Doc, typ2Tuple)
-    arrowDoc <- docLitS "->"
-    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, [])
-
+    pure $ (pure typ1Doc, ("->", innerHead) : innerBody)
+  _ -> pure (layoutType ltype, [])
 
 splitHsForallTypeFromBinders
   :: [LHsTyVarBndr () GhcPs]
   -> LHsType GhcPs
   -> ToBriDocM
-       (OpTree, [(BriDocNumbered, OpTree)])
+       (ToBriDocM BriDocNumbered, [(String, ToBriDocM BriDocNumbered)])
 splitHsForallTypeFromBinders binders typ = do
   (innerHead, innerBody) <- splitArrowType typ
-  outerHead <- do
-    tyVarDocs <- layoutTyVarBndrs binders
-    docAlt
-      -- :: forall x
-      --  . x
-      [ let open = docLit $ Text.pack "forall"
-        in  docSeq (open : processTyVarBndrsSingleline tyVarDocs)
-      -- :: forall
-      --      (x :: *)
-      --  . x
-      , docPar
-        (docLit (Text.pack "forall"))
-        (docLines $ tyVarDocs <&> \case
-          (tname, Nothing) ->
-            docEnsureIndent BrIndentRegular $ docLit tname
-          (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines
-            [ docCols ColTyOpPrefix [docParenLSep, docLit tname]
-            , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc]
-            , docLit $ Text.pack ")"
-            ]
-        )
-      ]
-  dotDoc <- docLitS "."
-  pure (OpLeaf outerHead, (dotDoc, innerHead) : innerBody)
+  pure
+    $ ( do
+        tyVarDocs <- layoutTyVarBndrs binders
+        docAlt
+          -- :: forall x
+          --  . x
+          [ let open = docLit $ Text.pack "forall"
+            in  docSeq (open : processTyVarBndrsSingleline tyVarDocs)
+          -- :: forall
+          --      (x :: *)
+          --  . x
+          , docPar
+            (docLit (Text.pack "forall"))
+            (docLines $ tyVarDocs <&> \case
+              (tname, Nothing) ->
+                docEnsureIndent BrIndentRegular $ docLit tname
+              (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines
+                [ docCols ColTyOpPrefix [docParenLSep, docLit tname]
+                , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc]
+                , docLit $ Text.pack ")"
+                ]
+            )
+          ]
+      , (".", innerHead) : innerBody
+      )
 
-layoutSplitArrowType
-  :: (OpTree, [(BriDocNumbered, OpTree)])
-  -> Bool
+
+joinSplitArrowType
+  :: Bool
+  -> (ToBriDocM BriDocNumbered, [(String, ToBriDocM BriDocNumbered)])
   -> 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)
+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
+      ]
 
-
-layoutType :: Bool -> ToBriDoc HsType
-layoutType forceHasComms ltype@(L _ typ) = docHandleComms ltype $ case typ of
+layoutType :: ToBriDoc HsType
+layoutType 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
@@ -187,20 +162,34 @@ layoutType forceHasComms ltype@(L _ typ) = docHandleComms ltype $ case typ of
       NotPromoted -> docHandleComms name $ docLit t
   HsForAllTy{} -> do
     parts <- splitArrowType ltype
-    layoutSplitArrowType parts (hasAnyCommentsBelow typ || forceHasComms)
+    joinSplitArrowType (hasAnyCommentsBelow typ) parts
   HsQualTy{} -> do
     parts <- splitArrowType ltype
-    layoutSplitArrowType parts (hasAnyCommentsBelow typ || forceHasComms)
+    joinSplitArrowType (hasAnyCommentsBelow typ) parts
   HsFunTy{} -> do
     parts <- splitArrowType ltype
-    layoutSplitArrowType parts (hasAnyCommentsBelow typ || forceHasComms)
-  HsParTy{} -> do
-    -- layouters <- mAsk
-    -- treeAndHasComms <-
-    --   layout_gatherOpTreeT layouters NoParen False id Nothing Nothing [] ltype
-    -- layout_opTree layouters True treeAndHasComms
-    parts <- splitArrowType ltype
-    layoutSplitArrowType parts (hasAnyCommentsBelow typ || forceHasComms)
+    joinSplitArrowType (hasAnyCommentsBelow typ) parts
+  HsParTy epAnn typ1 -> docHandleComms epAnn $ do
+    let (wrapOpen, wrapClose) = case epAnn of
+          EpAnn _ (AnnParen _ spanOpen spanClose) _ ->
+            (docHandleComms spanOpen, docHandleComms spanClose)
+          EpAnnNotUsed -> (id, id)
+    typeDoc1 <- shareDoc $ layoutType typ1
+    docAlt
+      [ 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
@@ -209,8 +198,8 @@ layoutType forceHasComms 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 False typHead
-    docRest <- (shareDoc . layoutType False) `mapM` typRest
+    docHead <- shareDoc $ layoutType typHead
+    docRest <- (shareDoc . layoutType) `mapM` typRest
     docAlt
       [ docSeq
       $ docForceSingleline docHead
@@ -218,8 +207,8 @@ layoutType forceHasComms ltype@(L _ typ) = docHandleComms ltype $ case typ of
       , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest)
       ]
   HsAppTy NoExtField typ1 typ2 -> do
-    typeDoc1 <- shareDoc $ layoutType False typ1
-    typeDoc2 <- shareDoc $ layoutType False typ2
+    typeDoc1 <- shareDoc $ layoutType typ1
+    typeDoc2 <- shareDoc $ layoutType typ2
     docAlt
       [ docSeq
         [docForceSingleline typeDoc1, docSeparator, docForceSingleline typeDoc2]
@@ -230,21 +219,21 @@ layoutType forceHasComms ltype@(L _ typ) = docHandleComms ltype $ case typ of
           EpAnn _ (AnnParen _ spanOpen spanClose) _ ->
             (docHandleComms spanOpen, docHandleComms spanClose)
           EpAnnNotUsed -> (id, id)
-    typeDoc1 <- shareDoc $ layoutType False typ1
+    typeDoc1 <- shareDoc $ layoutType typ1
     docAlt
       [ docSeq
         [ wrapOpen $ docLit $ Text.pack "["
         , docForceSingleline typeDoc1
         , wrapClose $ docLit $ Text.pack "]"
         ]
-      , docSetBaseY $ docLines
-        [ docCols
+      , docPar
+        (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
@@ -262,7 +251,7 @@ layoutType forceHasComms ltype@(L _ typ) = docHandleComms ltype $ case typ of
     wrapEnd   = docHandleComms close
     docWith start end = do
       typDocs <- typs `forM` \ty -> do
-        shareDoc $ docHandleListElemComms (layoutType False) ty
+        shareDoc $ docHandleListElemComms layoutType ty
       let
         line1 = docCols ColTyOpPrefix [wrapStart $ appSep start, head typDocs]
         lines =
@@ -280,12 +269,9 @@ layoutType forceHasComms ltype@(L _ typ) = docHandleComms ltype $ case typ of
             (docLines $ lines ++ [wrapEnd end])
         ]
   HsOpTy{} -> do
-    parts <- splitArrowType ltype
-    layoutSplitArrowType parts (hasAnyCommentsBelow ltype || forceHasComms)
-    -- layouters <- mAsk
-    -- treeAndHasComms <-
-    --   layout_gatherOpTreeT layouters NoParen False id Nothing Nothing [] ltype
-    -- layout_opTree layouters treeAndHasComms
+    layouters <- mAsk
+    treeAndHasComms <- layout_gatherOpTreeT layouters False 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
@@ -346,7 +332,7 @@ layoutType forceHasComms ltype@(L _ typ) = docHandleComms ltype $ case typ of
   --     }
   HsIParamTy epAnn (L _ (HsIPName ipName)) typ1 -> do
     let posColon = obtainAnnPos epAnn AnnDcolon
-    typeDoc1 <- shareDoc $ layoutType False typ1
+    typeDoc1 <- shareDoc $ layoutType typ1
     docHandleComms epAnn $ docAlt
       [ docSeq
         [ docLitS $ "?" ++ showSDocUnsafe (ftext ipName)
@@ -365,8 +351,8 @@ layoutType forceHasComms ltype@(L _ typ) = docHandleComms ltype $ case typ of
   -- TODO: test KindSig
   HsKindSig epAnn typ1 kind1 -> do
     let posColon = obtainAnnPos epAnn AnnDcolon
-    typeDoc1 <- shareDoc $ layoutType False typ1
-    kindDoc1 <- shareDoc $ layoutType False kind1
+    typeDoc1 <- shareDoc $ layoutType typ1
+    kindDoc1 <- shareDoc $ layoutType kind1
     docAlt
       [ docSeq
           [ docForceSingleline typeDoc1
@@ -385,7 +371,7 @@ layoutType forceHasComms ltype@(L _ typ) = docHandleComms ltype $ case typ of
           )
       ]
   HsBangTy epAnn (HsSrcBang NoSourceText NoSrcUnpack SrcStrict) innerTy -> do
-    docHandleComms epAnn $ docSeq [docLitS "!", layoutType False innerTy]
+    docHandleComms epAnn $ docSeq [docLitS "!", layoutType innerTy]
   HsBangTy {} ->
     briDocByExactInlineOnly "HsBangTy{}" ltype
   -- HsBangTy bang typ1 -> do
@@ -457,8 +443,7 @@ layoutType forceHasComms 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 False))
+    typDocs <- typs `forM` (shareDoc . docHandleListElemComms layoutType)
     let hasComments = hasAnyCommentsBelow ltype
     case splitFirstLast typDocs of
       FirstLastEmpty -> docSeq
@@ -521,8 +506,8 @@ layoutType forceHasComms 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 False ty
-    k <- shareDoc $ layoutType False kind
+    t <- shareDoc $ layoutType ty
+    k <- shareDoc $ layoutType kind
     docAlt
       [ docSeq
         [ docForceSingleline t
@@ -540,7 +525,7 @@ layoutTyVarBndrs
 layoutTyVarBndrs = mapM $ \case
   (L _ (UserTyVar _ _ name)) -> return $ (lrdrNameToText name, Nothing)
   (L _ (KindedTyVar _ _ lrdrName kind)) -> do
-    d <- shareDoc $ layoutType False kind
+    d <- shareDoc $ layoutType 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,8 +25,6 @@ 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
@@ -54,8 +52,4 @@ 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,14 +15,9 @@ 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 ->
-  --   Just $ BDEnsureIndent ind $ BDLines $ lines ++ [indented]
-  BDPar ind (BDLines (line1:lineR)) indented ->
-    Just
-      $  BDLines
-      $  [line1]
-      ++ fmap (BDEnsureIndent ind) lineR
-      ++ [BDEnsureIndent ind indented]
+  BDPar ind (BDLines lines) indented ->
+    -- error "foo"
+    Just $ BDEnsureIndent ind $ BDLines $ lines ++ [indented]
   BDPar ind (BDCols sig cols) indented ->
     Just $ BDCols sig (List.init cols ++ [BDPar ind (List.last cols) indented])
   BDPar BrIndentNone _ _ -> Nothing
@@ -56,9 +51,5 @@ 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,19 +160,13 @@ type ToBriDocM = MultiRWSS.MultiRWS
   '[[BrittanyError], Seq String] -- writer
   '[NodeAllocIndex, CommentCounter] -- state
 
-data OpParenMode
-  = NoParen
-  | ParenNoSpace
-  | ParenWithSpace
-  deriving (Eq, Show)
-
 data OpTree
-  = OpUnknown OpParenMode -- Z paren?
+  = OpUnknown Bool -- Z paren?
               (Maybe GHC.RealSrcLoc) -- paren open loc
               (Maybe GHC.RealSrcLoc) -- paren close loc
               OpTree -- left operand
-              [(BriDocNumbered, OpTree)] -- list of (next operand, symbol)
-  | OpKnown OpParenMode     -- with paren?
+              [(BriDocNumbered, BriDocNumbered)] -- list of (next operand, symbol)
+  | OpKnown Bool     -- with paren?
               (Maybe GHC.RealSrcLoc) -- paren open loc
               (Maybe GHC.RealSrcLoc) -- paren close loc
             GHC.Fixity   -- only Just after (successful!) lookup phase
@@ -186,25 +180,25 @@ data Layouters = Layouters
   { layout_expr :: ToBriDoc GHC.HsExpr
   , layout_lit :: GHC.HsLit GhcPs -> BriDocWrapped
   , layout_overLit :: GHC.OverLitVal -> BriDocWrapped
-  , layout_type :: Bool -> ToBriDoc GHC.HsType
+  , layout_type :: ToBriDoc GHC.HsType
   , layout_sigType :: ToBriDoc GHC.HsSigType
   , layout_stmt :: GHC.GuardLStmt GhcPs -> ToBriDocM BriDocNumbered
   , layout_gatherOpTreeE
-    :: OpParenMode
+    :: Bool
     -> Bool
     -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered)
     -> Maybe GHC.RealSrcLoc
     -> Maybe GHC.RealSrcLoc
-    -> [(ToBriDocM BriDocNumbered, OpTree)]
+    -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)]
     -> GHC.LHsExpr GhcPs
     -> ToBriDocM (OpTree, Bool)
   , layout_gatherOpTreeT
-    :: OpParenMode
+    :: Bool
     -> Bool
     -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered)
     -> Maybe GHC.RealSrcLoc
     -> Maybe GHC.RealSrcLoc
-    -> [(ToBriDocM BriDocNumbered, OpTree)]
+    -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)]
     -> GHC.LHsType GhcPs
     -> ToBriDocM (OpTree, Bool)
   , layout_opTree :: (OpTree, Bool) -> ToBriDocM BriDocNumbered
@@ -282,15 +276,6 @@ 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

source/library/Language/Haskell/Brittany/Internal/Util/AST.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Language.Haskell.Brittany.Internal.Util.AST where
+
+import           Language.Haskell.Brittany.Internal.Prelude
+
+import qualified Data.Text                     as Text
+import           GHC                            ( moduleName
+                                                , moduleNameString
+                                                , GenLocated(L)
+                                                )
+import qualified GHC
+import           GHC.Types.Name                 ( getOccString )
+import           GHC.Types.Name.Occurrence      ( occNameString
+                                                )
+import           GHC.Types.Name.Reader          ( RdrName
+                                                  ( Exact
+                                                  , Orig
+                                                  , Qual
+                                                  , Unqual
+                                                  )
+                                                )
+
+
+
+rdrNameToText :: RdrName -> Text
+-- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr
+rdrNameToText (Unqual occname) = Text.pack $ occNameString occname
+rdrNameToText (Qual mname occname) =
+  Text.pack $ moduleNameString mname ++ "." ++ occNameString occname
+rdrNameToText (Orig modul occname) =
+  Text.pack $ moduleNameString (moduleName modul) ++ occNameString occname
+rdrNameToText (Exact name) = Text.pack $ getOccString name
+
+getDeclBindingNames :: GHC.LHsDecl GhcPs -> [String]
+getDeclBindingNames (L _ decl) = case decl of
+  GHC.SigD _ (GHC.TypeSig _ ns _) ->
+    ns <&> \(L _ n) -> Text.unpack (rdrNameToText n)
+  GHC.ValD _ (GHC.FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n]
+  _ -> []

source/library/Language/Haskell/Brittany/Main.hs

@@ -6,20 +6,28 @@ module Language.Haskell.Brittany.Main where
 
 import Control.Monad (zipWithM)
 import qualified Control.Monad.Trans.Except as ExceptT
+import Data.CZipWith
 import qualified Data.Either
 import qualified Data.List.Extra
 import qualified Data.Monoid
+import qualified Data.Text as Text
 import qualified Data.Text.IO as Text.IO
+import qualified Data.Text.Lazy as TextL
+import DataTreePrint
 import GHC (GenLocated(L))
 import qualified GHC
+import qualified GHC.Driver.Session as GHC
+import qualified GHC.LanguageExtensions.Type as GHC
 import qualified GHC.OldList as List
 import GHC.Utils.Outputable (Outputable(..), showSDocUnsafe)
 import Language.Haskell.Brittany.Internal
 import Language.Haskell.Brittany.Internal.Config.Config
 import Language.Haskell.Brittany.Internal.Config.Types
+import Language.Haskell.Brittany.Internal.Components.Obfuscation
 import Language.Haskell.Brittany.Internal.Prelude
 import Language.Haskell.Brittany.Internal.Types
 import Language.Haskell.Brittany.Internal.Utils
+import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
 import Paths_brittany
 import qualified System.Directory as Directory
 import qualified System.Environment as Environment
@@ -301,14 +309,135 @@ coreIO
 coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
   ExceptT.runExceptT $ do
     let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO ()
-
-    inputVal <- case inputPathM of
-      Nothing -> do
-        inputString <- liftIO System.IO.getContents
-        pure $ Right inputString
-      Just p -> pure $ Left p
+    let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
+    -- there is a good of code duplication between the following code and the
+    -- `pureModuleTransform` function. Unfortunately, there are also a good
+    -- amount of slight differences: This module is a bit more verbose, and
+    -- it tries to use the full-blown `parseModule` function which supports
+    -- CPP (but requires the input to be a file..).
+    let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack
+    -- the flag will do the following: insert a marker string
+    -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with
+    -- "#include" before processing (parsing) input; and remove that marker
+    -- string from the transformation output.
+    -- The flag is intentionally misspelled to prevent clashing with
+    -- inline-config stuff.
     let
-      printErrorsAndWarnings errsWarns = do
+      hackAroundIncludes =
+        config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack
+    let
+      exactprintOnly = viaGlobal || viaDebug
+       where
+        viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack
+        viaDebug =
+          config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack
+
+    let
+      cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
+        then case cppMode of
+          CPPModeAbort -> do
+            return $ Left "Encountered -XCPP. Aborting."
+          CPPModeWarn -> do
+            putErrorLnIO
+              $ "Warning: Encountered -XCPP."
+              ++ " Be warned that -XCPP is not supported and that"
+              ++ " brittany cannot check that its output is syntactically"
+              ++ " valid in its presence."
+            return $ Right True
+          CPPModeNowarn -> return $ Right True
+        else return $ Right False
+    (parseResult, originalContents) <- case inputPathM of
+      Nothing -> do
+        -- TODO: refactor this hack to not be mixed into parsing logic
+        let
+          hackF s = if "#include" `isPrefixOf` s
+            then "-- BRITANY_INCLUDE_HACK " ++ s
+            else s
+        let
+          hackTransform = if hackAroundIncludes && not exactprintOnly
+            then List.intercalate "\n" . fmap hackF . lines'
+            else id
+        inputString <- liftIO System.IO.getContents
+        parseRes <- liftIO $ parseModuleFromString
+          ghcOptions
+          "stdin"
+          cppCheckFunc
+          (hackTransform inputString)
+        return (parseRes, Text.pack inputString)
+      Just p -> liftIO $ do
+        parseRes <- parseModule ghcOptions p cppCheckFunc
+        inputText <- Text.IO.readFile p
+        -- The above means we read the file twice, but the
+        -- GHC API does not really expose the source it
+        -- read. Should be in cache still anyways.
+        --
+        -- We do not use TextL.IO.readFile because lazy IO is evil.
+        -- (not identical -> read is not finished ->
+        -- handle still open -> write below crashes - evil.)
+        return (parseRes, inputText)
+    case parseResult of
+      Left left -> do
+        putErrorLn "parse error:"
+        putErrorLn left
+        ExceptT.throwE 60
+      Right (parsedSource, hasCPP) -> do
+        let moduleElementList = splitModuleDecls parsedSource
+        (inlineConf, perItemConf) <- do
+          resE <-
+            liftIO
+              $ ExceptT.runExceptT
+              $ extractCommentConfigs
+                putErrorLnIO
+                (extractDeclMap parsedSource)
+                moduleElementList
+          case resE of
+            Left (err, input) -> do
+              putErrorLn $ "Error: parse error in inline configuration:"
+              putErrorLn err
+              putErrorLn $ "  in the string \"" ++ input ++ "\"."
+              ExceptT.throwE 61
+            Right c -> -- trace (showTree c) $
+              pure c
+        let moduleConf = cZipWith fromOptionIdentity config inlineConf
+        when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do
+          let val = printTreeWithCustom 160 customLayouterF parsedSource
+          putErrorLn ("---- ast ----\n" ++ show val)
+        let
+          disableFormatting =
+            moduleConf & _conf_disable_formatting & confUnpack
+        (errsWarns, outSText, hasChanges) <- do
+          if
+            | disableFormatting -> do
+              pure ([], originalContents, False)
+            | exactprintOnly -> do
+              let r = Text.pack $ ExactPrint.exactPrint parsedSource
+              pure ([], r, r /= originalContents)
+            | otherwise -> do
+              let
+                omitCheck =
+                  moduleConf
+                    & _conf_errorHandling
+                    .> _econf_omit_output_valid_check
+                    .> confUnpack
+              (ews, outRaw) <- if hasCPP || omitCheck
+                then liftIO $ processModule (TraceFunc putErrorLnIO) moduleConf perItemConf moduleElementList
+                else liftIO
+                  $ pPrintModuleAndCheck (TraceFunc putErrorLnIO) moduleConf perItemConf moduleElementList
+              let
+                hackF s = fromMaybe s $ TextL.stripPrefix
+                  (TextL.pack "-- BRITANY_INCLUDE_HACK ")
+                  s
+              let
+                out = TextL.toStrict $ if hackAroundIncludes
+                  then
+                    TextL.intercalate (TextL.pack "\n")
+                    $ hackF
+                    <$> TextL.splitOn (TextL.pack "\n") outRaw
+                  else outRaw
+              out' <- if moduleConf & _conf_obfuscate & confUnpack
+                then lift $ obfuscate out
+                else pure out
+              pure $ (ews, out', out' /= originalContents)
         let
           customErrOrder ErrorInput{} = 4
           customErrOrder LayoutWarning{} = -1 :: Int
@@ -378,35 +507,23 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
               putErrorLn err
               putErrorLn $ "  in the string \"" ++ input ++ "\"."
             [] -> error "cannot happen"
-    parseResult <- liftIO $ parsePrintModuleCommon
-      (TraceFunc putErrorLnIO)
-      config
-      inputVal
-      ( putErrorLnIO
-        $ "Warning: Encountered -XCPP."
-        ++ " Be warned that -XCPP is not supported and that"
-        ++ " brittany cannot check that its output is syntactically"
-        ++ " valid in its presence."
-      )
-
-    case parseResult of
-      Left errWarns@[ErrorInput{}] -> do
-        printErrorsAndWarnings errWarns
-        ExceptT.throwE 60
-      Left errWarns@(ErrorMacroConfig{}: _) -> do
-        printErrorsAndWarnings errWarns
-        ExceptT.throwE 61
-      Left errWarns -> do
-        printErrorsAndWarnings errWarns
-        ExceptT.throwE 70
-      Right (errsWarns, outSText, hasChangesAct) -> do
-        printErrorsAndWarnings errsWarns
-
-        hasChanges <- liftIO $ hasChangesAct
-
         -- TODO: don't output anything when there are errors unless user
         -- adds some override?
-        let shouldOutput = not suppressOutput && not checkMode
+        let
+          hasErrors =
+            if config & _conf_errorHandling & _econf_Werror & confUnpack
+              then not $ null errsWarns
+              else 0 < maximum (-1 : fmap customErrOrder errsWarns)
+          outputOnErrs =
+            config
+              & _conf_errorHandling
+              & _econf_produceOutputOnErrors
+              & confUnpack
+          shouldOutput =
+            not suppressOutput
+              && not checkMode
+              && (not hasErrors || outputOnErrs)
+
         when shouldOutput
           $ addTraceSep (_conf_debug config)
           $ case outputPathM of
@@ -422,6 +539,7 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
           Nothing -> pure ()
           Just p -> liftIO $ putStrLn $ "formatting would modify: " ++ p
 
+        when hasErrors $ ExceptT.throwE 70
         return (if hasChanges then Changes else NoChanges)
  where
   addTraceSep conf =