Refactor file/module structure again again

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

brittany.cabal

@@ -126,6 +126,9 @@ 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
@@ -140,11 +143,10 @@ library
     Language.Haskell.Brittany.Internal.Components.BriDoc
     Language.Haskell.Brittany.Internal.Components.Obfuscation
     Language.Haskell.Brittany.Internal.Components.OpTree
-    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.ToBriDocTools
+    Language.Haskell.Brittany.Internal.WriteBriDoc
+    Language.Haskell.Brittany.Internal.PerModule
+    Language.Haskell.Brittany.Internal.PerDecl
     Language.Haskell.Brittany.Internal.Prelude
     Language.Haskell.Brittany.Internal.Transformations.T1_Alt
     Language.Haskell.Brittany.Internal.Transformations.T2_Floating
@@ -156,7 +158,6 @@ 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

@@ -0,0 +1,23 @@
+#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,3 +232,12 @@ meow =
      , something
      ]
   )
+
+#test operator-paren-alignment inside do and other op
+func = do
+  other
+      (   aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
+      **~ bbbbbbbbbbbbbbbbbb
+      **~ cccccccccccccccccccccccccccccccccccccccccccccccccc
+      )
+    == 13

data/15-regressions.blt

@@ -1051,3 +1051,33 @@ 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

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

@@ -12,27 +12,36 @@ 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.S3_ToBriDocTools
+import           Language.Haskell.Brittany.Internal.ToBriDocTools
 import           Language.Haskell.Brittany.Internal.Prelude
-import qualified Language.Haskell.Brittany.Internal.S1_Parsing
+import qualified Language.Haskell.Brittany.Internal.ParseExact
                                                as Parsing
-import qualified Language.Haskell.Brittany.Internal.S2_SplitModule
+import qualified Language.Haskell.Brittany.Internal.SplitExactModule
                                                as Splitting
-import           Language.Haskell.Brittany.Internal.StepOrchestrate
+import           Language.Haskell.Brittany.Internal.Components.Obfuscation
+                                                ( obfuscate )
+import           Language.Haskell.Brittany.Internal.PerModule
                                                 ( processModule )
 import           Language.Haskell.Brittany.Internal.Types
 import           Language.Haskell.Brittany.Internal.Utils
@@ -40,6 +49,162 @@ 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.
@@ -56,84 +221,12 @@ parsePrintModule
 parsePrintModule traceFunc configWithDebugs inputText = runExceptT $ do
   let config =
         configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig }
-  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
-
+  (_errsWarns, output, _) <- ExceptT $ liftIO $ parsePrintModuleCommon
+    traceFunc
+    config
+    (Right $ Text.unpack inputText)
+    (pure ())
+  pure output
 
 
 -- | 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 ++ "," ++ show x ++ ")") | (op, (x, _)) <- rs ]
-    ++ "]"
+         [ ("(" ++ showOp op ++ "," ++ displayOpTree x ++ ")") | (op, x) <- rs ]
+    ++ "])"
     )
   OpKnown p _ _ fixity tree ops ->
     (  "OpKnown "
@@ -90,6 +90,19 @@ 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@OpKnown{} -> ([], x)
   x@(OpUnknown paren locO locC left rest) ->
     let (warns, balancedLeft) = balanceOpTree allowUnqualify left
@@ -109,11 +122,7 @@ balanceOpTree allowUnqualify = \case
  where
   -- singleton :: BriDocNumbered -> StackElem
   -- singleton x = StackElem (Fixity NoSourceText 99 InfixN) (OpLeaf x) []
-  go
-    :: Stack
-    -> [(BriDocNumbered, BriDocNumbered)]
-    -> OpTree
-    -> Either [String] OpTree
+  go :: Stack -> [(BriDocNumbered, OpTree)] -> OpTree -> Either [String] OpTree
   go [] [] _ = Left []
   go [StackElem fxty cs] [] c =
     let (e1, eops) = shiftOps cs c in Right (known fxty e1 eops)
@@ -124,24 +133,20 @@ balanceOpTree allowUnqualify = \case
   go stack input@((opDoc, val) : inputR) c = case stack of
     [] -> do
       fxty <- docFixity opDoc
-      go [StackElem fxty [(c, opDoc)]] inputR (OpLeaf val)
+      go [StackElem fxty [(c, opDoc)]] inputR val
     (StackElem fixityS cs : stackR) -> do
       let Fixity _ precS dirS = fixityS
       fxty@(Fixity _ prec dir) <- docFixity opDoc
       case compare prec precS of
-        GT -> go (StackElem fxty [(c, opDoc)] : stack) inputR (OpLeaf val)
+        GT -> go (StackElem fxty [(c, opDoc)] : stack) inputR val
         LT -> do
           let (e1, eops) = shiftOps cs c
           go stackR input (known fixityS e1 eops)
         EQ -> case (dir, dirS) of
           (InfixR, InfixR) ->
-            go (StackElem fixityS ((c, opDoc) : cs) : stackR)
-               inputR
-               (OpLeaf val)
+            go (StackElem fixityS ((c, opDoc) : cs) : stackR) inputR val
           (InfixL, InfixL) ->
-            go (StackElem fixityS ((c, opDoc) : cs) : stackR)
-               inputR
-               (OpLeaf val)
+            go (StackElem fixityS ((c, opDoc) : cs) : stackR) inputR val
           _ -> Left []
   docFixity :: BriDocNumbered -> Either [String] Fixity
   docFixity (_, x) = case x of
@@ -163,9 +168,9 @@ balanceOpTree allowUnqualify = \case
               mapAccumL (\op (nextE, nextOp) -> (nextOp, (op, nextE))) o1 rest
         in  list ++ [(finalOp, final)]
       )
-  known = OpKnown False Nothing Nothing
+  known = OpKnown NoParen Nothing Nothing
 
-addAllParens :: Bool -> OpTree -> OpTree
+addAllParens :: OpParenMode -> OpTree -> OpTree
 addAllParens topLevelParen = \case
   x@OpLeaf{}    -> x
   x@OpUnknown{} -> x
@@ -174,16 +179,22 @@ addAllParens topLevelParen = \case
             locO
             locC
             fixity
-            (addAllParens True c)
-            [ (op, addAllParens True tree) | (op, tree) <- cs ]
+            (addAllParens ParenWithSpace c)
+            [ (op, addAllParens ParenWithSpace 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
   OpKnown paren locO locC fixity c cs ->
     OpKnown
-      (paren && outerFixity > fixLevel fixity)
+      -- We do not support removing superfluous parens around
+      -- function types yet:
+      (if outerFixity > fixLevel fixity || fixLevel fixity < 0
+        then paren
+        else NoParen
+      )
       locO
       locC
       fixity
@@ -193,6 +204,8 @@ remSuperfluousParens outerFixity = \case
 
 hardcodedFixity :: Bool -> String -> Maybe Fixity
 hardcodedFixity allowUnqualify = \case
+  --
+  "->"          -> Just $ Fixity NoSourceText (-1) InfixR
   "."           -> Just $ Fixity NoSourceText 9 InfixR
   "!!"          -> Just $ Fixity NoSourceText 9 InfixL
   "**"          -> Just $ Fixity NoSourceText 8 InfixR

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

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

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

@@ -0,0 +1,67 @@
+{-# 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/PerModule.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE DataKinds #-}
 
-module Language.Haskell.Brittany.Internal.StepOrchestrate
+module Language.Haskell.Brittany.Internal.PerModule
   ( processModule
   ) where
 
@@ -24,7 +24,6 @@ import           GHC                            ( EpaComment(EpaComment)
                                                 , GenLocated(L)
                                                 , HsModule(HsModule)
                                                 , LHsDecl
-                                                , SrcSpanAnn'(SrcSpanAnn)
                                                 )
 import qualified GHC.Types.SrcLoc              as GHC
 import qualified GHC.OldList                   as List
@@ -36,19 +35,23 @@ 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.S2_SplitModule
-                                                ( splitModuleStart )
-import           Language.Haskell.Brittany.Internal.S3_ToBriDocTools
-import           Language.Haskell.Brittany.Internal.S4_WriteBriDoc
+import           Language.Haskell.Brittany.Internal.SplitExactModule
+                                                ( getDeclBindingNames
+                                                , splitModuleStart
+                                                )
+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
+                                                ( commentToDoc )
 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 )
 
 
 
@@ -182,18 +185,6 @@ 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
@@ -231,41 +222,4 @@ 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/Prelude.hs

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

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

@@ -1,11 +1,11 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
--- TODO92
 
-module Language.Haskell.Brittany.Internal.S2_SplitModule
+module Language.Haskell.Brittany.Internal.SplitExactModule
   ( extractDeclMap
   , splitModuleDecls
   , splitModuleStart
+  , getDeclBindingNames
   ) where
 
 
@@ -15,6 +15,7 @@ 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)
@@ -47,11 +48,21 @@ 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
@@ -73,7 +84,6 @@ 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
 
 
 
@@ -427,3 +437,19 @@ 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/ToBriDoc/Comment.hs

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

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

@@ -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.S3_ToBriDocTools
+import Language.Haskell.Brittany.Internal.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 $ callLayouter layout_type typ
+      typeDoc   <- shareDoc $ callLayouter2 layout_type False typ
       let hasComments = hasAnyCommentsConnected ltycl
       layoutLhsAndType hasComments
                        sharedLhs
@@ -830,7 +830,7 @@ layoutTyVarBndr needsSep (L _ bndr) = case bndr of
       ++ [ docLit $ Text.pack "("
          , appSep $ docLit nameStr
          , appSep . docLit $ Text.pack "::"
-         , docForceSingleline $ callLayouter layout_type kind
+         , docForceSingleline $ callLayouter2 layout_type False kind
          , docLit $ Text.pack ")"
          ]
 
@@ -883,7 +883,7 @@ layoutTyFamInstDecl inClass outerNode tfid = do
     -- <$> hasAnyRegularCommentsConnected outerNode
     -- <*> hasAnyRegularCommentsRest innerNode
   let hasComments = hasAnyCommentsConnected outerNode
-  typeDoc <- shareDoc $ callLayouter layout_type typ
+  typeDoc <- shareDoc $ callLayouter2 layout_type False typ
   layoutLhsAndType hasComments lhs (docHandleComms posEqual $ docLit $ Text.pack "=") 1 typeDoc
 
 

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

@@ -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.S3_ToBriDocTools
+import           Language.Haskell.Brittany.Internal.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 $ callLayouter layout_type ty1
+      t <- shareDoc $ callLayouter2 layout_type False ty1
       e <- shareDoc $ callLayouter layout_expr exp1
       docAlt
         [ docSeq
@@ -238,52 +238,16 @@ layoutExpr lexpr@(L _ expr) = do
       --         || hasAnyCommentsConnected expOp
       layouters <- mAsk
       treeAndHasComms <-
-        layout_gatherOpTreeE layouters False False id Nothing Nothing [] lexpr
+        layout_gatherOpTreeE layouters NoParen False id Nothing Nothing [] lexpr
       layout_opTree layouters treeAndHasComms
     NegApp _ op _ -> do
       opDoc <- shareDoc $ layoutExpr op
       docSeq [docLit $ Text.pack "-", opDoc]
-    HsPar _epAnn (L _ (OpApp _topEpAnn _expLeft _expOp _)) -> do
-      -- 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
+    HsPar _epAnn _inner -> do
       layouters <- mAsk
       treeAndHasComms <-
-        layout_gatherOpTreeE layouters False False id Nothing Nothing [] lexpr
+        layout_gatherOpTreeE layouters NoParen False id Nothing Nothing [] lexpr
       layout_opTree layouters treeAndHasComms
-    HsPar epAnn innerExp -> docHandleComms epAnn $ do
-      let AnnParen _ spanOpen spanClose = anns epAnn
-      let wrapOpen                      = docHandleComms spanOpen
-      let wrapClose                     = docHandleComms spanClose
-      innerExpDoc <- shareDoc $ layoutExpr innerExp
-      docAlt
-        [ docSeq
-          [ wrapOpen $ docLit $ Text.pack "("
-          , docForceSingleline innerExpDoc
-          , wrapClose $ docLit $ Text.pack ")"
-          ]
-        , docSetBaseY $ docLines
-          [ docCols
-            ColOpPrefix
-            [ wrapOpen $ docLit $ Text.pack "("
-            , docAddBaseY (BrIndentSpecial 2) innerExpDoc
-            ]
-          , wrapClose $ docLit $ Text.pack ")"
-          ]
-        ]
     SectionL _ left op -> do -- TODO: add to testsuite
       leftDoc <- shareDoc $ layoutExpr left
       opDoc   <- shareDoc $ layoutExpr op
@@ -649,6 +613,17 @@ 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
@@ -735,17 +710,23 @@ layoutExpr lexpr@(L _ expr) = do
       let hasComments = hasAnyCommentsBelow lexpr
       case splitFirstLast elemDocs of
         FirstLastEmpty       -> docSeq [docLit $ Text.pack "[", closeDoc]
-        FirstLastSingleton (_, e) -> docAlt
+        FirstLastSingleton (_, ast, e) -> docAlt
           [ docSeq [openDoc, docForceSingleline e, closeDoc]
           , docSetBaseY $ docLines
-            [docSeq [openDoc, docSeparator, docSetBaseY $ e], closeDoc]
+            [ docSeq
+              [ openDoc
+              , docSeparator
+              , docSetBaseY $ docFlushCommsPost True ast e
               ]
-        FirstLast (_, e1) ems (finalCommaPos, eN) -> runFilteredAlternative $ do
+            , closeDoc
+            ]
+          ]
+        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
@@ -753,8 +734,12 @@ layoutExpr lexpr@(L _ expr) = do
                , closeDoc]
           addAlternative
             $ let start  = docCols ColList [appSep $ openDoc, e1]
-                  linesM = ems <&> \(p, d) ->
-                    docCols ColList [docHandleComms p docCommaSep, d]
+                  linesM = ems <&> \(p, ast, d) ->
+                    docCols
+                      ColList
+                      [ docHandleComms p docCommaSep
+                      , docFlushCommsPost True ast $ 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.S3_ToBriDocTools
+import           Language.Haskell.Brittany.Internal.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.S3_ToBriDocTools
+import Language.Haskell.Brittany.Internal.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.S3_ToBriDocTools
+import           Language.Haskell.Brittany.Internal.ToBriDocTools
 import           Language.Haskell.Brittany.Internal.Types
 
 

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

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

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

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

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

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

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

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

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

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

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

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

@@ -1,40 +0,0 @@
-{-# 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/Internal/WriteBriDoc.hs

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

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

@@ -6,28 +6,20 @@ 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
@@ -309,135 +301,14 @@ coreIO
 coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
   ExceptT.runExceptT $ do
     let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO ()
-    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
-      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
+    inputVal <- 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)
+        pure $ Right inputString
+      Just p -> pure $ Left p
     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)
+      printErrorsAndWarnings errsWarns = do
         let
           customErrOrder ErrorInput{} = 4
           customErrOrder LayoutWarning{} = -1 :: Int
@@ -507,23 +378,35 @@ 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
-          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)
-
+        let shouldOutput = not suppressOutput && not checkMode
         when shouldOutput
           $ addTraceSep (_conf_debug config)
           $ case outputPathM of
@@ -539,7 +422,6 @@ 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 =