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/11-extensions/implicitparams.blt

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

data/15-regressions.blt

@@ -964,7 +964,7 @@ func =
   Text.intercalate
     "\n"
     (   (\(abc, def) ->
-           abc ++ def ++ "lkajsdljkasdlkjasldjkljkasd" ++ asdasdasdasd
+          abc ++ def ++ "lkajsdljkasdlkjasldjkljkasd" ++ asdasdasdasd
         )
     <$> mylist
     )
@@ -998,3 +998,86 @@ func = do
 func False = 0
 -- comment
 func True  = 1
+
+#test nested do-block-with-comment issue
+dofunc = do
+  do
+    some
+    code
+  do
+    -- abc
+    more
+    code
+
+#test do-block paren non-alignment
+catchFunc = do
+  (func aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
+        aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
+    )
+    `catch` catcher
+
+#test comment after lambdacase
+func = \case
+  -- zzz
+  False -> 0
+  True  -> 1
+
+#test comment for recordfield
+func = myRecord { field      = -- comment
+                               if some condition then option one else option two
+                , otherfield = "text"
+                }
+
+#test multiline guards within parenthesis
+duGswidunBlxaq drux = DeeX.Vufcqqafi
+  (tiErihambSunxo drux)
+  (if
+    | geIqzscmBhiwo drux
+    -> Bmuh "Hpiioqa a yabufx ynyuq"
+    | liWaov drux
+    -> Bmuh "Ookhup ubqocf merr ukm ynyuq iitiop"
+    | tiErihambSunxo drux && bdp (alJukIkuh drux)
+    -> Bmuh "Jpgic dfaz dieb fs wreup hsv of ynyuq dio njr subdet"
+    | ukFinwuicUgIcclcep drux
+    -> Bmuh "Egwiqae-ka-molenqe codns dif'y ns csjyhth sisoyy"
+    | otherwise
+    -> Likiotq
+  )
+
+#test multiline-block-comment in do-block
+func = do
+  abc
+  {- some long
+     block comment -}
+  x <- readLine
+  print x
+
+#test broken layout on do + operator + paren + do
+func = do
+  (wrapper $ do
+    stmt1
+    stmt2
+    )
+    `shouldReturn` thing
+
+#golden minimize parens basic test
+-- brittany { lconfig_operatorParenthesisRefactorMode: PRMMinimize }
+func = func (abc) (def)
+#expected
+-- brittany { lconfig_operatorParenthesisRefactorMode: PRMMinimize }
+func = func abc def
+
+#test wandering comment at end of datadecl
+data ReformatParenMode
+  = ReformatParenModeKeep  -- don't modify parens at all
+  | ReformatParenModeClean -- remove unnecessary parens
+  | ReformatParenModeAll   -- add superfluous parens everywhere
+
+#test empty do block error
+func = process $ do
+  it "some long description to fill this line" $ do
+  ( aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
+    + bbbbbbbbbbbbbbbbbb
+    + cccccccccccccccccccccccccccccccccccccccccccccccccc
+    )
+    `shouldReturn` thing

data/30-tests-context-free.blt

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

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

@@ -10,26 +10,38 @@ module Language.Haskell.Brittany.Internal
    -- re-export from utils:
   , extractCommentConfigs
   , 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 GHC                     hiding ( parseModule )
+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           Language.Haskell.Brittany.Internal.StepOrchestrate
+import qualified Language.Haskell.Brittany.Internal.SplitExactModule
+                                               as Splitting
+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
@@ -37,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.
@@ -53,79 +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
-  (inlineConf, perItemConf) <-
-    mapExceptT (fmap $ bimap (\(a, b) -> [ErrorMacroConfig a b]) id)
-      $ extractCommentConfigs (useTraceFunc traceFunc) parsedSource
-  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 parsedSource
-          else lift $ pPrintModuleAndCheck traceFunc
-                                           moduleConfig
-                                           perItemConf
-                                           parsedSource
-        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
@@ -134,11 +235,11 @@ pPrintModuleAndCheck
   :: TraceFunc
   -> Config
   -> PerItemConfig
-  -> GHC.ParsedSource
+  -> FinalList ModuleElement p
   -> IO ([BrittanyError], TextL.Text)
-pPrintModuleAndCheck traceFunc conf inlineConf parsedModule = do
+pPrintModuleAndCheck traceFunc conf inlineConf moduleElementList = do
   let ghcOptions     = conf & _conf_forward & _options_ghc & runIdentity
-  (errs, output) <- processModule traceFunc conf inlineConf parsedModule
+  (errs, output) <- processModule traceFunc conf inlineConf moduleElementList
   parseResult <- Parsing.parseModuleFromString ghcOptions
                                                "output"
                                                (\_ -> return $ Right ())
@@ -162,10 +263,14 @@ parsePrintModuleTests conf filename input = do
   case parseResult of
     Left  err               -> return $ Left err
     Right (parsedModule, _) -> runExceptT $ do
+      let moduleElementList = Splitting.splitModuleDecls parsedModule
       (inlineConf, perItemConf) <-
         mapExceptT
           (fmap (bimap (\(a, _) -> "when parsing inline config: " ++ a) id))
-          $ extractCommentConfigs (\_ -> pure ()) parsedModule
+          $ extractCommentConfigs
+            (\_ -> pure ())
+            (Splitting.extractDeclMap parsedModule)
+            moduleElementList
       let moduleConf = cZipWith fromOptionIdentity conf inlineConf
       let omitCheck =
             conf
@@ -176,11 +281,11 @@ parsePrintModuleTests conf filename input = do
         then lift $ processModule (TraceFunc $ \_ -> pure ())
                                    moduleConf
                                    perItemConf
-                                   parsedModule
+                                   moduleElementList
         else lift $ pPrintModuleAndCheck (TraceFunc $ \_ -> pure ())
                                          moduleConf
                                          perItemConf
-                                         parsedModule
+                                         moduleElementList
       if null errs
         then pure $ TextL.toStrict $ ltext
         else throwE

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

@@ -32,8 +32,8 @@ displayOpTree = \case
     ++ " ["
     ++ intercalate
          ","
-         [ ("(" ++ showOp op ++ "," ++ show x ++ ")") | (op, (x, _)) <- rs ]
-    ++ "]"
+         [ ("(" ++ showOp op ++ "," ++ displayOpTree x ++ ")") | (op, x) <- rs ]
+    ++ "])"
     )
   OpKnown p _ _ fixity tree ops ->
     (  "OpKnown "
@@ -89,7 +89,20 @@ type Stack = [StackElem]
 
 balanceOpTree :: Bool -> OpTree -> ([BrittanyError], OpTree)
 balanceOpTree allowUnqualify = \case
-  x@OpLeaf{}  -> ([], x)
+  x@OpLeaf{} -> ([], x)
+  OpKnown paren locO locC fixity@(Fixity _ (-1) _) left rest ->
+    let
+        (warnsLeft, balancedLeft) = balanceOpTree allowUnqualify left
+        opRes =
+          [ (op, balanceOpTree allowUnqualify argTree) | (op, argTree) <- rest ]
+    in  ( warnsLeft ++ [ w | (_, (warns, _)) <- opRes, w <- warns ]
+        , OpKnown paren
+                  locO
+                  locC
+                  fixity
+                  balancedLeft
+                  [ (op, balanced) | (op, (_, balanced)) <- opRes ]
+        )
   x@OpKnown{} -> ([], x)
   x@(OpUnknown paren locO locC left rest) ->
     let (warns, balancedLeft) = balanceOpTree allowUnqualify left
@@ -109,11 +122,7 @@ balanceOpTree allowUnqualify = \case
  where
   -- singleton :: BriDocNumbered -> StackElem
   -- singleton x = StackElem (Fixity NoSourceText 99 InfixN) (OpLeaf x) []
-  go
-    :: 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
-  x@OpUnknown{} -> x
+  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,143 +204,145 @@ remSuperfluousParens outerFixity = \case
 
 hardcodedFixity :: Bool -> String -> Maybe Fixity
 hardcodedFixity allowUnqualify = \case
-  "."         -> Just $ Fixity NoSourceText 9 InfixR
-  "!!"        -> Just $ Fixity NoSourceText 9 InfixL
-  "**"        -> Just $ Fixity NoSourceText 8 InfixR
-  "^"         -> Just $ Fixity NoSourceText 8 InfixR
-  "^^"        -> Just $ Fixity NoSourceText 8 InfixR
-  "*"         -> Just $ Fixity NoSourceText 7 InfixL
-  "/"         -> Just $ Fixity NoSourceText 7 InfixL
-  "`quot`"    -> Just $ Fixity NoSourceText 7 InfixL
-  "`rem`"     -> Just $ Fixity NoSourceText 7 InfixL
-  "`div`"     -> Just $ Fixity NoSourceText 7 InfixL
-  "`mod`"     -> Just $ Fixity NoSourceText 7 InfixL
-  "+"         -> Just $ Fixity NoSourceText 6 InfixL
-  "-"         -> Just $ Fixity NoSourceText 6 InfixL
-  ":"         -> Just $ Fixity NoSourceText 5 InfixR
-  "=="        -> Just $ Fixity NoSourceText 4 InfixN
-  "/="        -> Just $ Fixity NoSourceText 4 InfixN
-  "<"         -> Just $ Fixity NoSourceText 4 InfixN
-  "<="        -> Just $ Fixity NoSourceText 4 InfixN
-  ">"         -> Just $ Fixity NoSourceText 4 InfixN
-  ">="        -> Just $ Fixity NoSourceText 4 InfixN
-  "&&"        -> Just $ Fixity NoSourceText 3 InfixR
-  "||"        -> Just $ Fixity NoSourceText 2 InfixR
-  ">>="       -> Just $ Fixity NoSourceText 1 InfixL
-  ">>"        -> Just $ Fixity NoSourceText 1 InfixL
-  "=<<"       -> Just $ Fixity NoSourceText 1 InfixR
-  "$"         -> Just $ Fixity NoSourceText 0 InfixR
-  "`seq`"     -> Just $ Fixity NoSourceText 0 InfixR
-  "$!"        -> Just $ Fixity NoSourceText 0 InfixR
-  "!"         -> Just $ Fixity NoSourceText 9 InfixL
-  "//"        -> Just $ Fixity NoSourceText 9 InfixL
-  "<>"        -> Just $ Fixity NoSourceText 6 InfixR
-  "<+>"       -> Just $ Fixity NoSourceText 5 InfixR
-  "<$"        -> Just $ Fixity NoSourceText 4 InfixL
-  "$>"        -> Just $ Fixity NoSourceText 4 InfixL
-  "<$>"       -> Just $ Fixity NoSourceText 4 InfixL
-  "<&>"       -> Just $ Fixity NoSourceText 1 InfixL
-  "&"         -> Just $ Fixity NoSourceText 1 InfixL
-  "<*>"       -> Just $ Fixity NoSourceText 4 InfixL
-  "<**>"      -> Just $ Fixity NoSourceText 4 InfixL
-  "*>"        -> Just $ Fixity NoSourceText 4 InfixL
-  "<*"        -> Just $ Fixity NoSourceText 4 InfixL
-  "`elem`"    -> Just $ Fixity NoSourceText 4 InfixN
-  "`notElem`" -> Just $ Fixity NoSourceText 4 InfixN
-  "++"        -> Just $ Fixity NoSourceText 5 InfixR
-  "%"         -> Just $ Fixity NoSourceText 7 InfixL
-  "<|>"       -> Just $ Fixity NoSourceText 3 InfixL
-  ".&."       -> Just $ Fixity NoSourceText 7 InfixL
-  ".|."       -> Just $ Fixity NoSourceText 5 InfixL
-  "`xor`"     -> Just $ Fixity NoSourceText 6 InfixL
-  "`shift`"   -> Just $ Fixity NoSourceText 8 InfixL
-  "`rotate`"  -> Just $ Fixity NoSourceText 8 InfixL
-  "`shiftL`"  -> Just $ Fixity NoSourceText 8 InfixL
-  "`shiftR`"  -> Just $ Fixity NoSourceText 8 InfixL
-  "`rotateL`" -> Just $ Fixity NoSourceText 8 InfixL
-  "`rotateR`" -> Just $ Fixity NoSourceText 8 InfixL
-  "+#"        -> Just $ Fixity NoSourceText 6 InfixL
-  ".^."       -> Just $ Fixity NoSourceText 6 InfixL
-  ".>>."      -> Just $ Fixity NoSourceText 8 InfixL
-  ".<<."      -> Just $ Fixity NoSourceText 8 InfixL
-  "!>>."      -> Just $ Fixity NoSourceText 8 InfixL
-  "!<<."      -> Just $ Fixity NoSourceText 8 InfixL
-  ">=>"       -> Just $ Fixity NoSourceText 1 InfixR
-  "<=<"       -> Just $ Fixity NoSourceText 1 InfixR
-  "&&&"       -> Just $ Fixity NoSourceText 3 InfixR
-  "<$!>"      -> fixity InfixL 4
+  --
+  "->"          -> Just $ Fixity NoSourceText (-1) InfixR
+  "."           -> Just $ Fixity NoSourceText 9 InfixR
+  "!!"          -> Just $ Fixity NoSourceText 9 InfixL
+  "**"          -> Just $ Fixity NoSourceText 8 InfixR
+  "^"           -> Just $ Fixity NoSourceText 8 InfixR
+  "^^"          -> Just $ Fixity NoSourceText 8 InfixR
+  "*"           -> Just $ Fixity NoSourceText 7 InfixL
+  "/"           -> Just $ Fixity NoSourceText 7 InfixL
+  "`quot`"      -> Just $ Fixity NoSourceText 7 InfixL
+  "`rem`"       -> Just $ Fixity NoSourceText 7 InfixL
+  "`div`"       -> Just $ Fixity NoSourceText 7 InfixL
+  "`mod`"       -> Just $ Fixity NoSourceText 7 InfixL
+  "+"           -> Just $ Fixity NoSourceText 6 InfixL
+  "-"           -> Just $ Fixity NoSourceText 6 InfixL
+  ":"           -> Just $ Fixity NoSourceText 5 InfixR
+  "=="          -> Just $ Fixity NoSourceText 4 InfixN
+  "/="          -> Just $ Fixity NoSourceText 4 InfixN
+  "<"           -> Just $ Fixity NoSourceText 4 InfixN
+  "<="          -> Just $ Fixity NoSourceText 4 InfixN
+  ">"           -> Just $ Fixity NoSourceText 4 InfixN
+  ">="          -> Just $ Fixity NoSourceText 4 InfixN
+  "&&"          -> Just $ Fixity NoSourceText 3 InfixR
+  "||"          -> Just $ Fixity NoSourceText 2 InfixR
+  ">>="         -> Just $ Fixity NoSourceText 1 InfixL
+  ">>"          -> Just $ Fixity NoSourceText 1 InfixL
+  "=<<"         -> Just $ Fixity NoSourceText 1 InfixR
+  "$"           -> Just $ Fixity NoSourceText 0 InfixR
+  "`seq`"       -> Just $ Fixity NoSourceText 0 InfixR
+  "$!"          -> Just $ Fixity NoSourceText 0 InfixR
+  "!"           -> Just $ Fixity NoSourceText 9 InfixL
+  "//"          -> Just $ Fixity NoSourceText 9 InfixL
+  "<>"          -> Just $ Fixity NoSourceText 6 InfixR
+  "<+>"         -> Just $ Fixity NoSourceText 5 InfixR
+  "<$"          -> Just $ Fixity NoSourceText 4 InfixL
+  "$>"          -> Just $ Fixity NoSourceText 4 InfixL
+  "<$>"         -> Just $ Fixity NoSourceText 4 InfixL
+  "<&>"         -> Just $ Fixity NoSourceText 1 InfixL
+  "&"           -> Just $ Fixity NoSourceText 1 InfixL
+  "<*>"         -> Just $ Fixity NoSourceText 4 InfixL
+  "<**>"        -> Just $ Fixity NoSourceText 4 InfixL
+  "*>"          -> Just $ Fixity NoSourceText 4 InfixL
+  "<*"          -> Just $ Fixity NoSourceText 4 InfixL
+  "`elem`"      -> Just $ Fixity NoSourceText 4 InfixN
+  "`notElem`"   -> Just $ Fixity NoSourceText 4 InfixN
+  "++"          -> Just $ Fixity NoSourceText 5 InfixR
+  "%"           -> Just $ Fixity NoSourceText 7 InfixL
+  "<|>"         -> Just $ Fixity NoSourceText 3 InfixL
+  ".&."         -> Just $ Fixity NoSourceText 7 InfixL
+  ".|."         -> Just $ Fixity NoSourceText 5 InfixL
+  "`xor`"       -> Just $ Fixity NoSourceText 6 InfixL
+  "`shift`"     -> Just $ Fixity NoSourceText 8 InfixL
+  "`rotate`"    -> Just $ Fixity NoSourceText 8 InfixL
+  "`shiftL`"    -> Just $ Fixity NoSourceText 8 InfixL
+  "`shiftR`"    -> Just $ Fixity NoSourceText 8 InfixL
+  "`rotateL`"   -> Just $ Fixity NoSourceText 8 InfixL
+  "`rotateR`"   -> Just $ Fixity NoSourceText 8 InfixL
+  "+#"          -> Just $ Fixity NoSourceText 6 InfixL
+  ".^."         -> Just $ Fixity NoSourceText 6 InfixL
+  ".>>."        -> Just $ Fixity NoSourceText 8 InfixL
+  ".<<."        -> Just $ Fixity NoSourceText 8 InfixL
+  "!>>."        -> Just $ Fixity NoSourceText 8 InfixL
+  "!<<."        -> Just $ Fixity NoSourceText 8 InfixL
+  ">=>"         -> Just $ Fixity NoSourceText 1 InfixR
+  "<=<"         -> Just $ Fixity NoSourceText 1 InfixR
+  "&&&"         -> Just $ Fixity NoSourceText 3 InfixR
+  "<$!>"        -> fixity InfixL 4
 
-  "~"         -> fixity InfixN 4
-  "~~"        -> fixity InfixN 4
-  ":~:"       -> Just $ Fixity NoSourceText 4 InfixN
-  ":~~:"      -> Just $ Fixity NoSourceText 4 InfixN
-  ":+:"       -> fixity InfixR 5
-  ":*:"       -> fixity InfixR 6
-  ":.:"       -> fixity InfixR 7
-  ":|"        -> fixity InfixR 5
+  "~"           -> fixity InfixN 4
+  "~~"          -> fixity InfixN 4
+  ":~:"         -> Just $ Fixity NoSourceText 4 InfixN
+  ":~~:"        -> Just $ Fixity NoSourceText 4 InfixN
+  ":+:"         -> fixity InfixR 5
+  ":*:"         -> fixity InfixR 6
+  ":.:"         -> fixity InfixR 7
+  ":|"          -> fixity InfixR 5
 
   -- non-base from random sources.
-  "<|"        -> Just $ Fixity NoSourceText 5 InfixR
-  "|>"        -> Just $ Fixity NoSourceText 5 InfixL
-  "><"        -> Just $ Fixity NoSourceText 5 InfixR
-  "$+$"       -> Just $ Fixity NoSourceText 5 InfixL
-  "\\\\"      -> Just $ Fixity NoSourceText 5 InfixN
-  ".>"        -> Just $ Fixity NoSourceText 9 InfixL
-  ":?"        -> Just $ Fixity NoSourceText 7 InfixN
-  ":-"        -> Just $ Fixity NoSourceText 9 InfixR
-  ".:"        -> Just $ Fixity NoSourceText 9 InfixR
-  "$!!"       -> fixity InfixR 0
-  "<$!!>"     -> fixity InfixL 4
+  "<|"          -> Just $ Fixity NoSourceText 5 InfixR
+  "|>"          -> Just $ Fixity NoSourceText 5 InfixL
+  "><"          -> Just $ Fixity NoSourceText 5 InfixR
+  "$+$"         -> Just $ Fixity NoSourceText 5 InfixL
+  "\\\\"        -> Just $ Fixity NoSourceText 5 InfixN
+  ".>"          -> Just $ Fixity NoSourceText 9 InfixL
+  ":?"          -> Just $ Fixity NoSourceText 7 InfixN
+  ":-"          -> Just $ Fixity NoSourceText 9 InfixR
+  ".:"          -> Just $ Fixity NoSourceText 9 InfixR
+  "$!!"         -> fixity InfixR 0
+  "<$!!>"       -> fixity InfixL 4
 
   -- lens, not complete!
-  "<|"        -> fixity InfixR 5
-  "|>"        -> fixity InfixL 5
-  "%~"        -> fixity InfixR 4
-  ".~"        -> fixity InfixR 4
-  "?~"        -> fixity InfixR 4
-  "<.~"       -> fixity InfixR 4
-  "<?~"       -> fixity InfixR 4
-  "+~"        -> fixity InfixR 4
-  "*~"        -> fixity InfixR 4
-  "-~"        -> fixity InfixR 4
-  "//~"       -> fixity InfixR 4
-  "^~"        -> fixity InfixR 4
-  "^^~"       -> fixity InfixR 4
-  "**~"       -> fixity InfixR 4
-  "||~"       -> fixity InfixR 4
-  "&&~"       -> fixity InfixR 4
-  ".="        -> fixity InfixN 4
-  "%="        -> fixity InfixN 4
-  "?="        -> fixity InfixN 4
-  "+="        -> fixity InfixN 4
-  "-="        -> fixity InfixN 4
-  "*="        -> fixity InfixN 4
-  "//="       -> fixity InfixN 4
-  "^="        -> fixity InfixN 4
-  "^^="       -> fixity InfixN 4
-  "**="       -> fixity InfixN 4
-  "&&="       -> fixity InfixN 4
-  "||="       -> fixity InfixN 4
-  "<~"        -> fixity InfixR 2
-  "<.="       -> fixity InfixN 4
-  "<?="       -> fixity InfixN 4
-  "<>~"       -> fixity InfixR 4
-  "<>="       -> fixity InfixN 4
-  "^.."       -> fixity InfixL 8
-  "^?"        -> fixity InfixL 8
-  "^?!"       -> fixity InfixL 8
-  "^@.."      -> fixity InfixL 8
-  "^@?"       -> fixity InfixL 8
-  "^@?!"      -> fixity InfixL 8
-  "^."        -> fixity InfixL 8
-  "^@."       -> fixity InfixL 8
-  "<."        -> fixity InfixR 9
-  ".>"        -> fixity InfixR 9
-  "<.>"       -> fixity InfixR 9
-  "@@~"       -> fixity InfixR 4
-  "@@="       -> fixity InfixR 4
-  "&~"        -> fixity InfixL 1
-  "??"        -> fixity InfixL 1
+  "<|"          -> fixity InfixR 5
+  "|>"          -> fixity InfixL 5
+  "%~"          -> fixity InfixR 4
+  ".~"          -> fixity InfixR 4
+  "?~"          -> fixity InfixR 4
+  "<.~"         -> fixity InfixR 4
+  "<?~"         -> fixity InfixR 4
+  "+~"          -> fixity InfixR 4
+  "*~"          -> fixity InfixR 4
+  "-~"          -> fixity InfixR 4
+  "//~"         -> fixity InfixR 4
+  "^~"          -> fixity InfixR 4
+  "^^~"         -> fixity InfixR 4
+  "**~"         -> fixity InfixR 4
+  "||~"         -> fixity InfixR 4
+  "&&~"         -> fixity InfixR 4
+  ".="          -> fixity InfixN 4
+  "%="          -> fixity InfixN 4
+  "?="          -> fixity InfixN 4
+  "+="          -> fixity InfixN 4
+  "-="          -> fixity InfixN 4
+  "*="          -> fixity InfixN 4
+  "//="         -> fixity InfixN 4
+  "^="          -> fixity InfixN 4
+  "^^="         -> fixity InfixN 4
+  "**="         -> fixity InfixN 4
+  "&&="         -> fixity InfixN 4
+  "||="         -> fixity InfixN 4
+  "<~"          -> fixity InfixR 2
+  "<.="         -> fixity InfixN 4
+  "<?="         -> fixity InfixN 4
+  "<>~"         -> fixity InfixR 4
+  "<>="         -> fixity InfixN 4
+  "^.."         -> fixity InfixL 8
+  "^?"          -> fixity InfixL 8
+  "^?!"         -> fixity InfixL 8
+  "^@.."        -> fixity InfixL 8
+  "^@?"         -> fixity InfixL 8
+  "^@?!"        -> fixity InfixL 8
+  "^."          -> fixity InfixL 8
+  "^@."         -> fixity InfixL 8
+  "<."          -> fixity InfixR 9
+  ".>"          -> fixity InfixR 9
+  "<.>"         -> fixity InfixR 9
+  "@@~"         -> fixity InfixR 4
+  "@@="         -> fixity InfixR 4
+  "&~"          -> fixity InfixL 1
+  "??"          -> fixity InfixL 1
 
 
   -- certain other operators
@@ -343,50 +356,62 @@ hardcodedFixity allowUnqualify = \case
   -- ".*?"       -> fixity _ _
   -- ".+."       -> fixity _ _
   -- ".-."       -> fixity _ _
-  ".&."       -> fixity InfixR 1
-  ".&&."      -> fixity InfixR 1
-  ".||."      -> fixity InfixR 1
-  "==>"       -> fixity InfixR 0
-  "=/="       -> fixity InfixN 4
-  "==="       -> fixity InfixN 4
-  ".:!"       -> fixity InfixL 9
-  ".:?"       -> fixity InfixL 9
+  ".&."         -> fixity InfixR 1
+  ".&&."        -> fixity InfixR 1
+  ".||."        -> fixity InfixR 1
+  "==>"         -> fixity InfixR 0
+  "=/="         -> fixity InfixN 4
+  "==="         -> fixity InfixN 4
+  ".:!"         -> fixity InfixL 9
+  ".:?"         -> fixity InfixL 9
   -- ".:>"       -> fixity _ _
   -- ".:>?"      -> fixity _ _
-  "<.>"       -> fixity InfixR 7
-  "</>"       -> fixity InfixR 5
-  "<?>"       -> fixity InfixL 9
+  "<.>"         -> fixity InfixR 7
+  "</>"         -> fixity InfixR 5
+  "<?>"         -> fixity InfixL 9
   -- "~"         -> fixity _ _
-  "==="       -> fixity InfixN 4
-  "!?"        -> fixity InfixL 9
-  "%=="       -> fixity InfixN 3
-  ".*"        -> fixity InfixR 8
-  ".**"       -> fixity InfixR 8
-  ".***"      -> fixity InfixR 8
-  ":?-"       -> fixity InfixN 1
-  "::-"       -> fixity InfixN 0
-  "&!"        -> fixity InfixL 1
-  
+  "==="         -> fixity InfixN 4
+  "!?"          -> fixity InfixL 9
+  "%=="         -> fixity InfixN 3
+  ".*"          -> fixity InfixR 8
+  ".**"         -> fixity InfixR 8
+  ".***"        -> fixity InfixR 8
+  ":?-"         -> fixity InfixN 1
+  "::-"         -> fixity InfixN 0
+  "&!"          -> fixity InfixL 1
+
   -- quickcheck (-state-machine)
-  ":&&"       -> fixity InfixL 9
-  ":||"       -> fixity InfixL 9
-  ":&&:"      -> fixity InfixL 9
-  ":=>"       -> fixity InfixL 9
-  ":=="       -> fixity InfixL 9
-  ":/="       -> fixity InfixL 9
-  ":<"        -> fixity InfixL 9
-  ":<="       -> fixity InfixL 9
-  ":>"        -> fixity InfixL 9
-  ":>="       -> fixity InfixL 9
-  ":->"       -> fixity InfixL 9
+  ":&&"         -> fixity InfixL 9
+  ":||"         -> fixity InfixL 9
+  ":&&:"        -> fixity InfixL 9
+  ":=>"         -> fixity InfixL 9
+  ":=="         -> fixity InfixL 9
+  ":/="         -> fixity InfixL 9
+  ":<"          -> fixity InfixL 9
+  ":<="         -> fixity InfixL 9
+  ":>"          -> fixity InfixL 9
+  ":>="         -> fixity InfixL 9
+  ":->"         -> fixity InfixL 9
+  ".=="         -> fixity InfixN 5
+  "./"          -> fixity InfixN 5
+  ".<"          -> fixity InfixN 5
+  ".<="         -> fixity InfixN 5
+  ".>"          -> fixity InfixN 5
+  ".>="         -> fixity InfixN 5
+  "`member`"    -> fixity InfixN 8
+  "`notMember`" -> fixity InfixN 8
+  ".//"         -> fixity InfixL 4
+  ".&&"         -> fixity InfixR 3
+  ".||"         -> fixity InfixR 2
+  ".=>"         -> fixity InfixR 1
 
   -- servant
-  ":>"        -> fixity InfixR 4
-  ":<|>"      -> fixity InfixR 3
-  ":-"        -> fixity InfixL 0
+  ":>"          -> fixity InfixR 4
+  ":<|>"        -> fixity InfixR 3
+  ":-"          -> fixity InfixL 0
 
   -- postgresql-simple
-  ":."        -> fixity InfixR 3 -- this has wildly different fixities in different libraries
+  ":."          -> fixity InfixR 3 -- this has wildly different fixities in different libraries
 
   -- ?
   -- ":-:"       -> fixity _ _
@@ -399,7 +424,7 @@ hardcodedFixity allowUnqualify = \case
   -- ":>:"       -> fixity _ _
   -- ":>=:"      -> fixity _ _
 
-  str         -> case (Safe.headMay str, Safe.lastMay str) of
+  str           -> case (Safe.headMay str, Safe.lastMay str) of
     (Just '\'', _) -> hardcodedFixity False (drop 1 str)
     (Just '`', Just '`') -> Just $ Fixity NoSourceText 9 InfixL
     (Just c, _) | Data.Char.isAlpha c && allowUnqualify -> hardcodedFixity False

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

@@ -26,7 +26,7 @@ import           Control.Monad.Trans.Except
 
 import           Language.Haskell.Brittany.Internal.Config.Config
 import           Language.Haskell.Brittany.Internal.Config.Types
-import Language.Haskell.Brittany.Internal.Util.AST
+import Language.Haskell.Brittany.Internal.Types
 import Language.Haskell.Brittany.Internal.Config.Types.Instances1 ()
 import Language.Haskell.Brittany.Internal.Config.Types.Instances2 ()
 -- import Language.Haskell.Brittany.Internal.Utils
@@ -44,46 +44,26 @@ data InlineConfigTarget
 
 extractCommentConfigs
   :: (String -> IO ())
-  -> GHC.ParsedSource
+  -> Map GHC.RealSrcSpan [String]
+  -> FinalList ModuleElement a
   -> ExceptT (String, String) IO (CConfig Maybe, PerItemConfig)
-extractCommentConfigs _putErrorLn modul = do
-  let (L _ (GHC.HsModule modAnn _ _ _ _ decls _ _)) = modul
-  let declMap :: Map GHC.RealSrcSpan [String]
-      declMap = Map.fromList
-        [ ( case span of
-            GHC.RealSrcSpan s _ -> s
-            GHC.UnhelpfulSpan _ -> error "unexpected UnhelpfulSpan"
-          , getDeclBindingNames decl
-          )
-        | decl <- decls
-        , let (L (GHC.SrcSpanAnn _ span) _) = decl
-        ]
-  let epAnnComms = \case
-        GHC.EpAnn _ _ (GHC.EpaComments prior) -> prior
-        GHC.EpAnn _ _ (GHC.EpaCommentsBalanced prior following) ->
-          prior ++ following
-        GHC.EpAnnNotUsed -> []
-  let gatheredComments =
-        join
-          $ epAnnComms modAnn
-          : [ epAnnComms epAnn | L (GHC.SrcSpanAnn epAnn _) _x <- decls ]
-  -- gatheredComments `forM_` \comm@(L anchor _) -> do
-  --   liftIO $ putErrorLn $ showOutputable comm
-  --   case Map.lookupLE (GHC.anchor anchor) declMap of
-  --     Nothing -> pure ()
-  --     Just (pos, le) -> do
-  --       liftIO $ putErrorLn $ "  le = " ++ show (toConstr le) ++ " at " ++ show
-  --         (ExactPrint.Utils.ss2deltaEnd pos (GHC.anchor anchor))
-  --   case Map.lookupGE (GHC.anchor anchor) declMap of
-  --     Nothing -> pure ()
-  --     Just (pos, ge) -> do
-  --       liftIO $ putErrorLn $ "  ge = " ++ show (toConstr ge) ++ " at " ++ show
-  --         (ExactPrint.Utils.ss2deltaStart (GHC.anchor anchor) pos)
+extractCommentConfigs _putErrorLn declMap moduleElementList = do
+  let comments = concatMapFinal (void moduleElementList) $ \case
+        MEExactModuleHead modul -> case GHC.hsmodAnn $ GHC.unLoc modul of
+          GHC.EpAnn _ _ (GHC.EpaComments prior) -> prior
+          GHC.EpAnn _ _ (GHC.EpaCommentsBalanced prior following) ->
+            prior ++ following
+          GHC.EpAnnNotUsed -> []
+        MEPrettyModuleHead{}   -> []
+        MEImportDecl{}         -> []
+        MEDecl{}               -> []
+        MEComment (_, comment) -> [comment]
+        MEWhitespace{}         -> []
   lineConfigs <- sequence
     [ case Butcher.runCmdParserSimpleString line2 parser of
         Left  err            -> throwE (err, line2)
         Right (target, conf) -> pure $ (GHC.anchor anchr, target, conf)
-    | L anchr (EpaComment comm _) <- gatheredComments
+    | L anchr (EpaComment comm _) <- comments
     , Just line1                  <- case comm of
       EpaLineComment l ->
         [ List.stripPrefix "-- BRITTANY" l

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

@@ -0,0 +1,225 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE DataKinds #-}
+
+module Language.Haskell.Brittany.Internal.PerModule
+  ( processModule
+  ) where
+
+import           Language.Haskell.Brittany.Internal.Prelude
+
+import qualified Control.Monad.Trans.MultiRWS.Strict
+                                               as MultiRWSS
+import           Data.CZipWith
+import qualified Data.Map.Strict               as Map
+import qualified Data.Text.Lazy                as TextL
+import qualified Data.Text.Lazy.Builder        as TextL.Builder
+import qualified Data.Text.Lazy.Builder        as Text.Builder
+import qualified GHC
+import           GHC                            ( EpaComment(EpaComment)
+                                                , EpaCommentTok
+                                                  ( EpaBlockComment
+                                                  , EpaEofComment
+                                                  , EpaLineComment
+                                                  )
+                                                , GenLocated(L)
+                                                , HsModule(HsModule)
+                                                , LHsDecl
+                                                )
+import qualified GHC.Types.SrcLoc              as GHC
+import qualified GHC.OldList                   as List
+import           GHC.Types.SrcLoc               ( srcSpanFileName_maybe )
+import qualified Language.Haskell.GHC.ExactPrint
+                                               as ExactPrint
+
+import           Language.Haskell.Brittany.Internal.Components.BriDoc
+import           Language.Haskell.Brittany.Internal.Config.Types
+import           Language.Haskell.Brittany.Internal.Config.Types.Instances2
+                                                ( )
+import           Language.Haskell.Brittany.Internal.SplitExactModule
+                                                ( getDeclBindingNames
+                                                , splitModuleStart
+                                                )
+import           Language.Haskell.Brittany.Internal.ToBriDocTools
+import           Language.Haskell.Brittany.Internal.WriteBriDoc
+                                                ( ppBriDoc )
+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.Utils
+import           Language.Haskell.Brittany.Internal.ToBriDoc
+                                                ( layouters )
+import           Language.Haskell.Brittany.Internal.PerDecl
+                                                ( ppToplevelDecl )
+
+
+
+-- BrittanyErrors can be non-fatal warnings, thus both are returned instead
+-- of an Either.
+-- This should be cleaned up once it is clear what kinds of errors really
+-- can occur.
+processModule
+  :: TraceFunc
+  -> Config
+  -> PerItemConfig
+  -> FinalList ModuleElement p
+  -> IO ([BrittanyError], TextL.Text)
+processModule traceFunc conf inlineConf moduleElems = do
+  let FinalList moduleElementsStream = moduleElems
+      ((out, errs), debugStrings) =
+        runIdentity
+          $ MultiRWSS.runMultiRWSTNil
+          $ MultiRWSS.withMultiWriterAW
+          $ MultiRWSS.withMultiWriterAW
+          $ MultiRWSS.withMultiWriterW
+          $ MultiRWSS.withMultiReader traceFunc
+          $ moduleElementsStream
+              (\modElem cont -> do
+                processModuleElement modElem
+                cont
+              )
+              (\x -> do
+              -- mTell $ TextL.Builder.fromString "\n"
+                pure x
+              )
+    -- _tracer = 
+    --   -- if Seq.null debugStrings
+    --   -- then id
+    --   -- else
+    --     trace ("---- DEBUGMESSAGES ---- ")
+    --       . foldr (seq . join trace) id debugStrings
+  debugStrings `forM_` \s -> useTraceFunc traceFunc s
+  -- moduleElementsStream
+  --   (\el rest -> do
+  --     case el of
+  --       MEExactModuleHead{}  -> useTraceFunc traceFunc "MEExactModuleHead"
+  --       MEPrettyModuleHead{} -> useTraceFunc traceFunc "MEPrettyModuleHead"
+  --       MEImportDecl{}       -> useTraceFunc traceFunc "MEImportDecl"
+  --       MEDecl decl _ ->
+  --         useTraceFunc
+  --           traceFunc
+  --           ("MEDecl " ++ intercalate "," (getDeclBindingNames decl))
+  --       MEComment (y, L _ (EpaComment (EpaLineComment str) _)) ->
+  --         useTraceFunc traceFunc ("MEComment " ++ show y ++ " " ++ str)
+  --       MEComment (y, L _ (EpaComment (EpaBlockComment str) _)) ->
+  --         useTraceFunc traceFunc ("MEComment " ++ show y ++ " " ++ take 5 str)
+  --       MEComment (y, _) ->
+  --         useTraceFunc traceFunc ("MEComment " ++ show y ++ " _")
+  --       MEWhitespace dp -> useTraceFunc traceFunc ("MEWhitespace " ++ show dp)
+  --     rest
+  --   )
+  --   (\_ -> pure ())
+  pure (errs, TextL.Builder.toLazyText out)
+ where
+  shouldReformatHead =
+    conf & _conf_layout & _lconfig_reformatModulePreamble & confUnpack
+  wrapNonDeclToBriDoc =
+    MultiRWSS.withMultiReader conf . MultiRWSS.withMultiState_
+      (CommentCounter 0)
+  processModuleElement
+    :: ModuleElement
+    -> MultiRWSS.MultiRWST
+         '[TraceFunc]
+         '[Text.Builder.Builder , [BrittanyError] , Seq String]
+         '[]
+         Identity
+         ()
+  processModuleElement = \case
+    MEExactModuleHead modHead -> if shouldReformatHead
+      then do
+        let FinalList startElems =
+              splitModuleStart
+                modHead
+                ( fmap GHC.realSrcSpanStart
+                $ obtainAnnPos (GHC.hsmodAnn $ GHC.unLoc modHead) GHC.AnnWhere
+                )
+        startElems
+          (\modElem cont -> do
+            processModuleElement modElem
+            cont
+          )
+          (\_ -> pure ())
+      else wrapNonDeclToBriDoc $ do
+        bdMay <- ppModuleHead modHead
+        case bdMay of
+          Nothing -> pure ()
+          Just bd -> do
+            ppBriDoc bd True
+        mTell $ Text.Builder.fromString "\n"
+    MEPrettyModuleHead (L loc modHead) -> wrapNonDeclToBriDoc $ do
+      case modHead of
+        HsModule epAnn _layoutInfo Nothing Nothing _ _ _ _ -> do
+          (bd, _) <-
+            briDocMToPPM layouters
+            $ maybe id docFlushRemaining (srcSpanFileName_maybe loc)
+            $ docHandleComms epAnn docSeparator
+          ppBriDoc bd True
+        HsModule _ _layoutInfo Nothing Just{} _ _ _ _ ->
+          error "brittany internal error: exports without module name"
+        HsModule epAnn _layoutInfo (Just n) les _ _ _ _ -> do
+          (bd, _) <-
+            briDocMToPPM layouters
+            $ maybe id docFlushRemaining (srcSpanFileName_maybe loc)
+            $ moduleNameExportBridoc epAnn n les
+          ppBriDoc bd True
+    MEImportDecl importDecl immediateAfterComms -> wrapNonDeclToBriDoc $ do
+      (bd, _) <- briDocMToPPM layouters $ docSeq
+        (layoutImport importDecl : map commentToDoc immediateAfterComms)
+      ppBriDoc bd False
+    MEDecl decl immediateAfterComms -> do
+      let declConfig = getDeclConfig conf inlineConf decl
+      MultiRWSS.withMultiReader declConfig
+        $ MultiRWSS.withMultiState_ (CommentCounter 0)
+        $ ppToplevelDecl decl immediateAfterComms
+    MEComment (ind, L _ (EpaComment (EpaLineComment str) _)) -> do
+      mTell $ TextL.Builder.fromString (replicate ind ' ' ++ str)
+      mTell $ TextL.Builder.fromString "\n"
+    MEComment (ind, L _ (EpaComment (EpaBlockComment str) _)) -> do
+      mTell $ TextL.Builder.fromString (replicate ind ' ' ++ str)
+      mTell $ TextL.Builder.fromString "\n"
+    MEComment (_, L _ (EpaComment EpaEofComment _)) -> pure ()
+    MEComment    _  -> mTell $ TextL.Builder.fromString "some other comment"
+    MEWhitespace dp -> do
+      -- mTell $ TextL.Builder.fromString "B"
+      -- mTell $ TextL.Builder.fromString ("whitespace " ++ show dp)
+      ppmMoveToExactLoc dp
+
+-- Prints the information associated with the module annotation
+-- This includes the imports
+-- This returns a `Maybe` because it only produces a BriDocNumbered if
+-- re-formatting the module head is enabled. We maybe should change that
+-- for consistency.
+ppModuleHead :: GHC.ParsedSource -> PPMLocal (Maybe BriDocNumbered)
+ppModuleHead lmod = do
+  processDefault lmod $> Nothing
+
+processDefault
+  :: (ExactPrint.ExactPrint ast, MonadMultiWriter Text.Builder.Builder m)
+     -- , MonadMultiReader ExactPrint.Types.Anns m
+  => GHC.Located ast
+  -> m ()
+processDefault x = do
+  let str = ExactPrint.exactPrint x
+  -- this hack is here so our print-empty-module trick does not add
+  -- a newline at the start if there actually is no module header / imports
+  -- / anything.
+  -- TODO: instead the appropriate annotation could be removed when "cleaning"
+  --       the module (header). This would remove the need for this hack!
+  case str of
+    "\n" -> return ()
+    _    -> mTell $ Text.Builder.fromString $ List.dropWhileEnd ((==) '\n') str
+
+
+getDeclConfig :: Config -> PerItemConfig -> GHC.LHsDecl GhcPs -> Config
+getDeclConfig config inlineConf decl = cZipWith fromOptionIdentity config
+  $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf]))
+ where
+  declBindingNames = getDeclBindingNames decl
+  mBindingConfs    = declBindingNames <&> \n ->
+    Map.lookup n $ _icd_perBinding inlineConf
+  mDeclConf = case GHC.locA $ GHC.getLoc decl of
+    GHC.RealSrcSpan x _ -> Map.lookup x $ _icd_perAnchor inlineConf
+    GHC.UnhelpfulSpan{} -> Nothing
+
+

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,17 +1,21 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
--- TODO92
 
-module Language.Haskell.Brittany.Internal.S2_SplitModule
-  ( splitModule
-  )
-where
+module Language.Haskell.Brittany.Internal.SplitExactModule
+  ( extractDeclMap
+  , splitModuleDecls
+  , splitModuleStart
+  , getDeclBindingNames
+  ) where
 
 
 
 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)
@@ -44,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
@@ -64,6 +78,8 @@ import qualified Language.Haskell.GHC.ExactPrint.Types
 import qualified Language.Haskell.GHC.ExactPrint.Utils
                                                as ExactPrint
 import           Safe                           ( maximumMay )
+import qualified Control.Monad.Trans.Writer.Strict
+                                               as WriterS
 
 import           Language.Haskell.Brittany.Internal.Components.BriDoc
 import           Language.Haskell.Brittany.Internal.ToBriDoc.Module
@@ -71,75 +87,109 @@ import           Language.Haskell.Brittany.Internal.Types
 
 
 
-splitModule
-  :: Bool
-  -> GHC.ParsedSource
-  -> Maybe GHC.RealSrcLoc
-  -> FinalList ModuleElement ExactPrint.Pos
-splitModule shouldReformatHead lmod posWhere = do
-  let L moduleSpan modl          = lmod
-      HsModule _ _layout _name _exports imports decls _ _ = modl
-      (hsModAnn', finalComments) = case GHC.hsmodAnn modl of
-        EpAnn a modAnns (EpaCommentsBalanced prior post) ->
-          (EpAnn a modAnns (EpaCommentsBalanced prior []), post)
-        _ -> (GHC.hsmodAnn modl, [])
-      moduleWithoutComments =
-        L moduleSpan modl { GHC.hsmodAnn = hsModAnn', GHC.hsmodDecls = [] }
-  lastSpan <- if shouldReformatHead
-    then do
-      finalYield $ MEPrettyModuleHead moduleWithoutComments
-      let locBeforeImports =
-            maximumMay 
-              $  [ realSrcSpanEnd $ anchor a
-                 | L a _ <- case hsModAnn' of
-                   EpAnn _ _ (EpaComments cs             ) -> cs
-                   EpAnn _ _ (EpaCommentsBalanced cs1 cs2) -> cs1 ++ cs2
-                   EpAnnNotUsed -> error "unexpected EpAnnNotUsed"
-                 ]
-              ++ [ pos | Just pos <- [posWhere] ]
-      let (importLines, lastSpan) = finalToList $ transformToImportLine
-            ( maybe 0 srcLocLine locBeforeImports
-            , maybe 1 srcLocCol  locBeforeImports
-            )
-            imports
-      let commentedImports = groupifyImportLines importLines
-      sortCommentedImports commentedImports `forM_` \case
-        EmptyLines n ->
-          finalYield $ MEWhitespace $ DifferentLine n 1
-        SamelineComment{} ->
-          error "brittany internal error: splitModule SamelineComment"
-        NewlineComment  comm   -> finalYield $ MEComment comm
-        ImportStatement record -> do
-          forM_ (commentsBefore record) $ finalYield . MEComment
-          finalYield
-            $ MEImportDecl (importStatement record) (commentsSameline record)
-          forM_ (commentsAfter record) $ finalYield . MEComment
-      pure $ lastSpan
-    else do
-      finalYield $ MEExactModuleHead moduleWithoutComments
-      pure
-        $  maybe (1, 1) (ExactPrint.ss2posEnd)
-        $  maximumMay
-        $  [ GHC.anchor a
-           | L a _ <- GHC.priorComments $ case hsModAnn' of
-             EpAnn _ _ cs -> cs
-             EpAnnNotUsed -> error "unexpected EpAnnNotUsed"
-           ]
-        ++ [ s | AddEpAnn _ (EpaSpan s) <- GHC.am_main $ GHC.anns hsModAnn' ]
-        ++ [ GHC.anchor a
-           | L da _ <- GHC.hsmodImports modl
-           , L a  _ <- case GHC.ann da of
-             EpAnn _ _ (EpaComments l          ) -> l
-             EpAnn _ _ (EpaCommentsBalanced _ l) -> l
-             EpAnnNotUsed                        -> []
-           ]
-        ++ [ span
-           | L (SrcSpanAnn _ (GHC.RealSrcSpan span _)) _ <- GHC.hsmodImports
-             modl
-           ]
-  spanAfterDecls <- enrichDecls lastSpan decls
+extractDeclMap :: GHC.ParsedSource -> Map GHC.RealSrcSpan [String]
+extractDeclMap modul =
+  Map.fromList
+    [ ( case span of
+          GHC.RealSrcSpan s _ -> s
+          GHC.UnhelpfulSpan _ -> error "unexpected UnhelpfulSpan"
+      , getDeclBindingNames decl
+      )
+    | decl <- decls
+    , let (L (GHC.SrcSpanAnn _ span) _) = decl
+    ]
+  where (L _ (GHC.HsModule _ _ _ _ _ decls _ _)) = modul
+
+splitModuleDecls :: GHC.ParsedSource -> FinalList ModuleElement ExactPrint.Pos
+splitModuleDecls lmod = do
+  let
+    L moduleSpan modl          = lmod
+    HsModule _ _layout _name _exports imports decls _ _ = modl
+    (hsModAnn', finalComments) = case GHC.hsmodAnn modl of
+      EpAnn a modAnns (EpaCommentsBalanced prior post) ->
+        (EpAnn a modAnns (EpaCommentsBalanced prior []), post)
+      _ -> (GHC.hsmodAnn modl, [])
+    (newImports, commsAfterImports) = case Data.List.Extra.unsnoc imports of
+      Just (allButLast, L (SrcSpanAnn epAnn s@(RealSrcSpan span _)) lastImp) ->
+        case epAnn of
+          EpAnnNotUsed -> (imports, [])
+          EpAnn anch anns (EpaComments cs) ->
+            let
+              (keepImports, moveImports) =
+                partition
+                  (\(L cAnch _) ->
+                    GHC.srcSpanEndLine (anchor cAnch) <= GHC.srcSpanEndLine span
+                  )
+                  cs
+              newLastImport =
+                L (SrcSpanAnn (EpAnn anch anns (EpaComments keepImports)) s)
+                  lastImp
+            in
+              ( allButLast ++ [newLastImport]
+              , List.sortOn (\(L l _) -> l) moveImports
+              )
+          EpAnn anch anns (EpaCommentsBalanced cs1 cs2) ->
+            let newLastImport =
+                  L (SrcSpanAnn (EpAnn anch anns (EpaComments cs1)) s) lastImp
+            in  (allButLast ++ [newLastImport], List.sortOn (\(L l _) -> l) cs2)
+      _ -> ([], [])
+    moduleWithoutComments = L moduleSpan modl { GHC.hsmodAnn     = hsModAnn'
+                                              , GHC.hsmodDecls   = []
+                                              , GHC.hsmodImports = newImports
+                                              }
+  spanAfterImports <- do
+    finalYield $ MEExactModuleHead moduleWithoutComments
+    pure
+      $  maybe (0, 1) (ExactPrint.ss2posEnd)
+      $  maximumMay
+      $  [ GHC.anchor a
+         | L a _ <- GHC.priorComments $ case hsModAnn' of
+           EpAnn _ _ cs -> cs
+           EpAnnNotUsed -> error "unexpected EpAnnNotUsed"
+         ]
+      ++ [ s | AddEpAnn _ (EpaSpan s) <- GHC.am_main $ GHC.anns hsModAnn' ]
+      ++ [ span
+         | L (SrcSpanAnn _ (RealSrcSpan span _)) _ <- GHC.hsmodImports modl
+         ]
+      ++ [ span
+         | L (SrcSpanAnn _ (GHC.RealSrcSpan span _)) _ <- GHC.hsmodImports modl
+         ]
+  spanBeforeDecls <- enrichComms spanAfterImports commsAfterImports
+  spanAfterDecls  <- enrichDecls spanBeforeDecls decls
   enrichComms spanAfterDecls finalComments
 
+splitModuleStart
+  :: GHC.ParsedSource
+  -> Maybe GHC.RealSrcLoc
+  -> FinalList ModuleElement ExactPrint.Pos
+splitModuleStart modul posWhere = do
+  finalYield $ MEPrettyModuleHead modul
+  let locBeforeImports =
+        maximumMay
+          $  [ realSrcSpanEnd $ anchor a
+             | L a _ <- case GHC.hsmodAnn $ unLoc modul of
+               EpAnn _ _ (EpaComments cs             ) -> cs
+               EpAnn _ _ (EpaCommentsBalanced cs1 cs2) -> cs1 ++ cs2
+               EpAnnNotUsed -> error "unexpected EpAnnNotUsed"
+             ]
+          ++ [ pos | Just pos <- [posWhere] ]
+  let (importLines, lastSpan) = finalToList $ transformToImportLine
+        ( maybe 0 srcLocLine locBeforeImports
+        , maybe 1 srcLocCol  locBeforeImports
+        )
+        (GHC.hsmodImports $ unLoc modul)
+  let commentedImports = groupifyImportLines importLines
+  sortCommentedImports commentedImports `forM_` \case
+    EmptyLines n -> finalYield $ MEWhitespace $ DifferentLine n 1
+    SamelineComment{} ->
+      error "brittany internal error: splitModuleStart SamelineComment"
+    NewlineComment  comm   -> finalYield $ MEComment comm
+    ImportStatement record -> do
+      forM_ (commentsBefore record) $ finalYield . MEComment
+      finalYield $ MEImportDecl (importStatement record)
+                                (commentsSameline record)
+      forM_ (commentsAfter record) $ finalYield . MEComment
+  pure $ lastSpan
 
 enrichComms
   :: ExactPrint.Pos -> [LEpaComment] -> FinalList ModuleElement ExactPrint.Pos
@@ -150,60 +200,46 @@ enrichComms lastSpanEnd = \case
       SameLine i        -> SameLine i
       DifferentLine l c -> DifferentLine (l - 1) c
     enrichComms (ExactPrint.ss2posEnd span) commRest
-  (L (Anchor span _) (EpaComment comm _) : commRest) -> do
+  lcomm@(L (Anchor span _) _) : commRest -> do
     case ExactPrint.ss2delta lastSpanEnd span of
       SameLine i -> do
-        finalYield $ MEComment (i, comm)
+        finalYield $ MEComment (i, lcomm)
       DifferentLine l c -> do
         finalYield $ MEWhitespace $ DifferentLine (l - 1) c
-        finalYield $ MEComment (0, comm)
+        finalYield $ MEComment (0, lcomm)
     enrichComms (ExactPrint.ss2posEnd span) commRest
 
 enrichDecls
   :: ExactPrint.Pos -> [LHsDecl GhcPs] -> FinalList ModuleElement ExactPrint.Pos
 enrichDecls lastSpanEnd = \case
   [] -> finalPure $ lastSpanEnd
-  L (SrcSpanAnn dAnn rlspan@(GHC.RealSrcSpan span _)) decl : declRest ->
+  ldecl@(L (SrcSpanAnn dAnn (GHC.RealSrcSpan span _)) _) : declRest ->
     case dAnn of
-      EpAnn dAnchor items (EpaComments dComments) -> do
+      EpAnn _dAnchor _items (EpaComments _dComments) -> do
         let
-          (innerComments, outerComments) =
-            partition
-              (\(L (Anchor anch _) _) ->
-                realSrcSpanStart anch < realSrcSpanEnd span
-              )
-              dComments
-          withoutOuterComments =
-            (L
-              (SrcSpanAnn (EpAnn dAnchor items (EpaComments innerComments))
-                          rlspan
-              )
-              decl
-            )
-          commentExtract = \case
-            L (GHC.Anchor anch _) EpaComment{} -> ExactPrint.ss2posEnd anch
-          -- It would be really nice if `ExactPrint.ss2posEnd span` was
-          -- sufficient. But for some reason the comments are not
-          -- (consistently) included in the length of the anchor. I.e.
-          -- there are cases where a syntax tree node has an anchor from
-          -- pos A -> pos B. But then somewhere _below_ that node is a
-          -- comment that has an anchor pos B -> pos C.
-          -- We simply detect this here.
-          -- We probably do some redundant `SYB.everything` lookups
-          -- throughout the code now. But optimizing it is not easy, and
-          -- at worst it is larger constant factor on the size of the
-          -- input, so it isn't _that_ bad.
-          fixedSpanEnd =
-            SYB.everything
-              max
-              (SYB.mkQ (ExactPrint.ss2posEnd span) commentExtract)
-              decl
+          commentExtract
+            :: [LEpaComment] -> WriterS.Writer [LEpaComment] [LEpaComment]
+          commentExtract comms = do
+            let (innerComments, outerComments) =
+                  partition
+                    (\(L (Anchor anch _) _) ->
+                      (  realSrcSpanStart anch < realSrcSpanEnd span
+                      && realSrcSpanEnd anch > realSrcSpanStart span
+                      )
+                    )
+                    comms
+            WriterS.tell outerComments
+            pure innerComments
+          (ldecl', extractedComments) = WriterS.runWriter
+            $ SYB.everywhereM (SYB.mkM commentExtract) ldecl
         case ExactPrint.ss2delta lastSpanEnd span of
           SameLine{} -> pure ()
           DifferentLine n _ ->
             finalYield $ MEWhitespace $ DifferentLine (n - 1) 1
+        let fixedSpanEnd = ExactPrint.ss2posEnd span
         let (afterComms, span2) = finalToList
-              $ enrichComms fixedSpanEnd (reverse outerComments)
+              $ enrichComms fixedSpanEnd
+                            (List.sortOn (\(L l _) -> l) extractedComments)
         let (immediate, later) =
               List.span
                 (\case
@@ -212,8 +248,9 @@ enrichDecls lastSpanEnd = \case
                 )
                 afterComms
         finalYield
-          $ MEDecl withoutOuterComments [ comm | MEComment comm <- immediate ]
-          -- $ MEDecl ldecl []
+          $ MEDecl
+            ldecl'
+            [ (ind, GHC.ac_tok comm) | MEComment (ind, L _ comm) <- immediate ]
         later `forM_` finalYield
         enrichDecls span2 declRest
       EpAnn _anchor _items (EpaCommentsBalanced{}) ->
@@ -227,8 +264,8 @@ enrichDecls lastSpanEnd = \case
 
 data ImportLine
   = EmptyLines Int
-  | SamelineComment (Int, EpaCommentTok)
-  | NewlineComment  (Int, EpaCommentTok) -- indentation and comment
+  | SamelineComment (Int, LEpaComment)
+  | NewlineComment  (Int, LEpaComment) -- indentation and comment
   | ImportStatement ImportStatementRecord
 
 instance Show ImportLine where
@@ -241,10 +278,10 @@ instance Show ImportLine where
         (length $ commentsAfter r)
 
 data ImportStatementRecord = ImportStatementRecord
-  { commentsBefore   :: [(Int, EpaCommentTok)]
+  { commentsBefore   :: [(Int, LEpaComment)]
   , importStatement  :: LImportDecl GhcPs
   , commentsSameline :: [(Int, EpaCommentTok)]
-  , commentsAfter    :: [(Int, EpaCommentTok)]
+  , commentsAfter    :: [(Int, LEpaComment)]
   }
 
 instance Show ImportStatementRecord where
@@ -263,13 +300,13 @@ transformToImportLine startPos is =
       :: [LEpaComment] -> ExactPrint.Pos -> FinalList ImportLine ExactPrint.Pos
     flattenComms = \case
       [] -> finalPure
-      (L (Anchor span _) (EpaComment comm _) : commRest) -> \lastSpanEnd -> do
+      lcomm@(L (Anchor span _) _) : commRest -> \lastSpanEnd -> do
         case ExactPrint.ss2delta lastSpanEnd span of
           SameLine i -> do
-            finalYield $ SamelineComment (i, comm)
+            finalYield $ SamelineComment (i, lcomm)
           DifferentLine l c -> do
             finalYield $ EmptyLines (l - 1)
-            finalYield $ NewlineComment (c - 1, comm)
+            finalYield $ NewlineComment (c - 1, lcomm)
         flattenComms commRest (ExactPrint.ss2posEnd span)
     flattenDecls
       :: [LImportDecl GhcPs]
@@ -278,43 +315,41 @@ transformToImportLine startPos is =
     flattenDecls = \case
       [] -> finalPure
       (L (SrcSpanAnn epAnn srcSpan@(RealSrcSpan declSpan _)) decl : declRest)
-        -> \lastSpanEnd ->
+         -> \lastSpanEnd ->
           let (commsBefore, commsAfter, cleanEpAnn) = case epAnn of
                 EpAnn anch s (EpaComments cs) ->
                   ([], reverse cs, EpAnn anch s (EpaComments []))
                 EpAnn anch s (EpaCommentsBalanced cs1 cs2) ->
                   (reverse cs1, reverse cs2, EpAnn anch s (EpaComments []))
                 EpAnnNotUsed -> ([], [], EpAnnNotUsed)
-          in
-            do
-              span1 <- flattenComms commsBefore lastSpanEnd
-              let newlines = case ExactPrint.ss2delta span1 declSpan of
-                    SameLine _        -> 0
-                    DifferentLine i _ -> i - 1
-              finalYield
-                $ EmptyLines newlines
-              finalYield $ ImportStatement ImportStatementRecord
-                { commentsBefore   = []
-                , importStatement  = L (SrcSpanAnn cleanEpAnn srcSpan) decl
-                , commentsSameline = []
-                , commentsAfter    = []
-                }
-              span2 <- flattenComms commsAfter (ExactPrint.ss2posEnd declSpan)
-              flattenDecls declRest span2
+          in  do
+                span1 <- flattenComms commsBefore lastSpanEnd
+                let newlines = case ExactPrint.ss2delta span1 declSpan of
+                      SameLine _        -> 0
+                      DifferentLine i _ -> i - 1
+                finalYield $ EmptyLines newlines
+                finalYield $ ImportStatement ImportStatementRecord
+                  { commentsBefore   = []
+                  , importStatement  = L (SrcSpanAnn cleanEpAnn srcSpan) decl
+                  , commentsSameline = []
+                  , commentsAfter    = []
+                  }
+                span2 <- flattenComms commsAfter (ExactPrint.ss2posEnd declSpan)
+                flattenDecls declRest span2
       (L (SrcSpanAnn _epAnn UnhelpfulSpan{}) _decl : _declRest) ->
         error "UnhelpfulSpan"
   in
     flattenDecls is startPos
 
-data Partial = PartialCommsOnly [(Int, EpaCommentTok)]
+data Partial = PartialCommsOnly [(Int, LEpaComment)]
              | PartialImport ImportStatementRecord
 
 groupifyImportLines :: [ImportLine] -> [ImportLine]
 groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls
  where
   go acc [] = case acc of
-    PartialCommsOnly comms ->
-      reverse comms `forM_` \comm -> finalYield $ NewlineComment comm
+    PartialCommsOnly comms -> reverse comms `forM_` \comm ->
+      finalYield $ NewlineComment comm
     PartialImport partialRecord ->
       finalYield $ ImportStatement $ unpartial partialRecord
   go acc (line1 : lineR) = do
@@ -326,9 +361,10 @@ groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls
           pure $ PartialCommsOnly []
         SamelineComment comm -> do
           pure $ PartialCommsOnly (comm : comms)
-        NewlineComment comm -> pure $ PartialCommsOnly (comm : comms)
-        ImportStatement record ->
-          pure $ PartialImport $ record { commentsBefore = comms }
+        NewlineComment  comm   -> pure $ PartialCommsOnly (comm : comms)
+        ImportStatement record -> pure $ PartialImport $ record
+          { commentsBefore = comms
+          }
       PartialImport partialRecord -> case line1 of
         e@EmptyLines{} -> do
           finalYield $ ImportStatement $ unpartial partialRecord
@@ -337,7 +373,8 @@ groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls
         SamelineComment comm -> do
           if (null $ commentsAfter partialRecord)
             then pure $ PartialImport partialRecord
-              { commentsSameline = comm : commentsSameline partialRecord
+              { commentsSameline = tokenOnly comm
+                                   : commentsSameline partialRecord
               }
             else pure $ PartialImport partialRecord
               { commentsAfter = comm : commentsAfter partialRecord
@@ -353,6 +390,8 @@ groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls
           pure $ PartialImport $ record { commentsBefore = contestedComments }
             -- comments in between will stay connected to the following decl
     go newAcc lineR
+  tokenOnly :: (Int, LEpaComment) -> (Int, EpaCommentTok)
+  tokenOnly (ind, L _ (EpaComment tok _)) = (ind, tok)
   unpartial :: ImportStatementRecord -> ImportStatementRecord
   unpartial partialRecord = ImportStatementRecord
     { commentsBefore   = reverse (commentsBefore partialRecord)
@@ -365,7 +404,7 @@ groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls
 sortCommentedImports :: [ImportLine] -> [ImportLine]
 sortCommentedImports =
   -- TODO92 we don't need this unpackImports, it is implied later in the process
-                       mergeGroups . map (fmap (sortGroups)) . groupify
+  mergeGroups . map (fmap (sortGroups)) . groupify
  where
   -- unpackImports :: [ImportLine] -> [ImportLine]
   -- unpackImports xs = xs >>= \case
@@ -381,8 +420,8 @@ sortCommentedImports =
     Left  x -> [x]
     Right y -> ImportStatement <$> y
   sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord]
-  sortGroups =
-    List.sortOn (moduleNameString . unLoc . ideclName . unLoc . importStatement)
+  sortGroups = List.sortOn
+    (moduleNameString . unLoc . ideclName . unLoc . importStatement)
   groupify :: [ImportLine] -> [Either ImportLine [ImportStatementRecord]]
   groupify cs = go [] cs
    where
@@ -398,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/StepOrchestrate.hs

@@ -1,254 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Language.Haskell.Brittany.Internal.StepOrchestrate
-  ( processModule
-  )
-where
-
-import           Language.Haskell.Brittany.Internal.Prelude
-
-import qualified Control.Monad.Trans.MultiRWS.Strict
-                                               as MultiRWSS
-import           Data.CZipWith
-import qualified Data.Map.Strict               as Map
-import qualified Data.Text.Lazy                as TextL
-import qualified Data.Text.Lazy.Builder        as TextL.Builder
-import qualified Data.Text.Lazy.Builder        as Text.Builder
-import qualified GHC
-import           GHC                            ( EpaCommentTok
-                                                  ( EpaBlockComment
-                                                  , EpaEofComment
-                                                  , EpaLineComment
-                                                  )
-                                                , GenLocated(L)
-                                                , HsModule(HsModule)
-                                                , LHsDecl
-                                                , SrcSpanAnn'(SrcSpanAnn)
-                                                )
-import qualified GHC.Types.SrcLoc              as GHC
-import qualified GHC.OldList                   as List
-import           GHC.Types.SrcLoc               ( srcSpanFileName_maybe )
-import qualified Language.Haskell.GHC.ExactPrint
-                                               as ExactPrint
-
-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
-                                                ( splitModule )
-import           Language.Haskell.Brittany.Internal.S3_ToBriDocTools
-import           Language.Haskell.Brittany.Internal.S4_WriteBriDoc
-                                                ( ppBriDoc )
-import           Language.Haskell.Brittany.Internal.ToBriDoc.Decl
-import           Language.Haskell.Brittany.Internal.ToBriDoc.Import
-import           Language.Haskell.Brittany.Internal.ToBriDoc.Module
-import           Language.Haskell.Brittany.Internal.Types
-import           Language.Haskell.Brittany.Internal.Util.AST
-import           Language.Haskell.Brittany.Internal.Utils
-import           Language.Haskell.Brittany.Internal.ToBriDoc (layouters)
-
-
-
--- BrittanyErrors can be non-fatal warnings, thus both are returned instead
--- of an Either.
--- This should be cleaned up once it is clear what kinds of errors really
--- can occur.
-processModule
-  :: TraceFunc
-  -> Config
-  -> PerItemConfig
-  -> GHC.ParsedSource
-  -> IO ([BrittanyError], TextL.Text)
-processModule traceFunc conf inlineConf parsedModule = do
-  let shouldReformatHead =
-        conf & _conf_layout & _lconfig_reformatModulePreamble & confUnpack
-  let
-    wrapNonDeclToBriDoc = MultiRWSS.withMultiReader conf
-      . MultiRWSS.withMultiState_ (CommentCounter 0)
-    FinalList moduleElementsStream = splitModule
-      shouldReformatHead
-      parsedModule
-      (fmap GHC.realSrcSpanStart $ obtainAnnPos (GHC.hsmodAnn $ GHC.unLoc parsedModule) GHC.AnnWhere)
-    ((out, errs), debugStrings) =
-      runIdentity
-        $ MultiRWSS.runMultiRWSTNil
-        $ MultiRWSS.withMultiWriterAW
-        $ MultiRWSS.withMultiWriterAW
-        $ MultiRWSS.withMultiWriterW
-        $ MultiRWSS.withMultiReader traceFunc
-        $ moduleElementsStream
-            (\modElem cont -> do
-              case modElem of
-                MEExactModuleHead modHead -> wrapNonDeclToBriDoc $ do
-                  bdMay <- ppModuleHead modHead
-                  case bdMay of
-                    Nothing -> pure ()
-                    Just bd -> ppBriDoc bd True
-                MEPrettyModuleHead (L loc modHead) -> wrapNonDeclToBriDoc $ do
-                  case modHead of
-                    HsModule epAnn _layoutInfo Nothing Nothing _ _ _ _ -> do
-                      (bd, _) <-
-                        briDocMToPPM layouters
-                        $ maybe id
-                                docFlushRemaining
-                                (srcSpanFileName_maybe loc)
-                        $ docHandleComms epAnn docSeparator
-                      ppBriDoc bd True
-                    HsModule _ _layoutInfo Nothing Just{} _ _ _ _ -> error
-                      "brittany internal error: exports without module name"
-                    HsModule epAnn _layoutInfo (Just n) les _ _ _ _ -> do
-                      (bd, _) <-
-                        briDocMToPPM layouters
-                        $ maybe id
-                                docFlushRemaining
-                                (srcSpanFileName_maybe loc)
-                        $ moduleNameExportBridoc epAnn n les
-                      ppBriDoc bd True
-                MEImportDecl importDecl immediateAfterComms ->
-                  wrapNonDeclToBriDoc $ do
-                    (bd, _) <-
-                      briDocMToPPM layouters
-                        $ docSeq
-                            ( layoutImport importDecl
-                            : map commentToDoc immediateAfterComms
-                            )
-                    ppBriDoc bd False
-                MEDecl decl immediateAfterComms -> do
-                  let declConfig = getDeclConfig conf inlineConf decl
-                  MultiRWSS.withMultiReader declConfig
-                    $ MultiRWSS.withMultiState_ (CommentCounter 0)
-                    $ ppToplevelDecl decl immediateAfterComms
-                MEComment (ind, EpaLineComment str) -> do
-                  mTell $ TextL.Builder.fromString (replicate ind ' ' ++ str)
-                  mTell $ TextL.Builder.fromString "\n"
-                MEComment (ind, EpaBlockComment str) -> do
-                  mTell $ TextL.Builder.fromString (replicate ind ' ' ++ str)
-                  mTell $ TextL.Builder.fromString "\n"
-                MEComment (_, EpaEofComment) -> pure ()
-                MEComment _ ->
-                  mTell $ TextL.Builder.fromString "some other comment"
-                MEWhitespace dp -> do
-                  -- mTell $ TextL.Builder.fromString "B"
-                  -- mTell $ TextL.Builder.fromString ("whitespace " ++ show dp)
-                  ppmMoveToExactLoc dp
-              cont
-            )
-            (\x -> do
-              -- mTell $ TextL.Builder.fromString "\n"
-              pure x
-            )
-    -- _tracer = 
-    --   -- if Seq.null debugStrings
-    --   -- then id
-    --   -- else
-    --     trace ("---- DEBUGMESSAGES ---- ")
-    --       . foldr (seq . join trace) id debugStrings
-  debugStrings `forM_` \s -> useTraceFunc traceFunc s
-  -- moduleElementsStream
-  --   (\el rest -> do
-  --     case el of
-  --       MEExactModuleHead{}  -> useTraceFunc traceFunc "MEExactModuleHead"
-  --       MEPrettyModuleHead{} -> useTraceFunc traceFunc "MEPrettyModuleHead"
-  --       MEImportDecl{}       -> useTraceFunc traceFunc "MEImportDecl"
-  --       MEDecl decl _        -> useTraceFunc traceFunc ("MEDecl " ++ intercalate "," (getDeclBindingNames decl))
-  --       MEComment (y, EpaLineComment str) -> useTraceFunc traceFunc ("MEComment " ++ show y ++ " " ++ str)
-  --       MEComment (y, _) -> useTraceFunc traceFunc ("MEComment " ++ show y ++ " _")
-  --       MEWhitespace dp -> useTraceFunc traceFunc ("MEWhitespace " ++ show dp)
-  --     rest
-  --   )
-  --   (\_ -> pure ())
-  pure (errs, TextL.Builder.toLazyText out)
-
-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
--- re-formatting the module head is enabled. We maybe should change that
--- for consistency.
-ppModuleHead :: GHC.ParsedSource -> PPMLocal (Maybe BriDocNumbered)
-ppModuleHead lmod = do
-  processDefault lmod $> Nothing
-
-processDefault
-  :: (ExactPrint.ExactPrint ast, MonadMultiWriter Text.Builder.Builder m)
-     -- , MonadMultiReader ExactPrint.Types.Anns m
-  => GHC.Located ast
-  -> m ()
-processDefault x = do
-  let str = ExactPrint.exactPrint x
-  -- this hack is here so our print-empty-module trick does not add
-  -- a newline at the start if there actually is no module header / imports
-  -- / anything.
-  -- TODO: instead the appropriate annotation could be removed when "cleaning"
-  --       the module (header). This would remove the need for this hack!
-  case str of
-    "\n" -> return ()
-    _    -> mTell $ Text.Builder.fromString $ List.dropWhileEnd ((==) '\n') str
-
-
-getDeclConfig
-  :: Config
-  -> PerItemConfig
-  -> GHC.LHsDecl GhcPs
-  -> Config
-getDeclConfig config inlineConf decl = cZipWith fromOptionIdentity config
-  $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf]))
- where
-  declBindingNames = getDeclBindingNames decl
-  mBindingConfs =
-    declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf
-  mDeclConf = case GHC.locA $ GHC.getLoc decl of
-    GHC.RealSrcSpan x _ -> Map.lookup x $ _icd_perAnchor inlineConf
-    GHC.UnhelpfulSpan{} -> Nothing
-
-ppToplevelDecl :: LHsDecl GhcPs -> [(Int, EpaCommentTok)] -> PPMLocal ()
-ppToplevelDecl decl immediateAfterComms = do
-  exactprintOnly <- mAsk <&> \declConfig ->
-    declConfig & _conf_roundtrip_exactprint_only & confUnpack
-  bd <- fmap fst $ if exactprintOnly
-    then briDocMToPPM layouters
-      $ docSeq
-        (briDocByExactNoComment decl : map commentToDoc immediateAfterComms)
-    else do
-      let innerDoc = case decl of
-            L (SrcSpanAnn _ (GHC.RealSrcSpan s _)) _ ->
-              docFlushRemaining (GHC.srcSpanFile s) $ layoutDecl decl
-            _ -> layoutDecl decl
-      (r, errorCount) <- briDocMToPPM layouters
-        $ docSeq (innerDoc : map commentToDoc immediateAfterComms)
-      if errorCount == 0
-        then pure (r, 0)
-        else briDocMToPPM layouters $ briDocByExactNoComment decl
-  ppBriDoc bd False
-  let commCntIn = connectedCommentCount decl
-  commCntOut <- mGet
-  when (commCntIn /= commCntOut) $ if commCntOut < commCntIn
-    then mTell
-      [ ErrorUnusedComments decl
-                            (unCommentCounter commCntIn)
-                            (unCommentCounter commCntOut)
-      ]
-    else mTell
-      [ ErrorUnusedComments decl
-                            (unCommentCounter commCntIn)
-                            (unCommentCounter commCntOut)
-      ]
-      -- error
-      -- $  "internal brittany error: inconsistent comment count ("
-      -- ++ show commCntOut
-      -- ++ ">"
-      -- ++ show commCntIn
-      -- ++ ")!"
-

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

@@ -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]
@@ -494,7 +494,7 @@ createDetailsDoc consNameStr details = case details of
               ]
             , docSeq
               [ docHandleComms posOpen $ docLitS "{"
-              , docSeparator
+              , docHandleComms epAnn docSeparator
               , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar
                 fName1
                 (docSeq [docLitS "::", docSeparator, fType1])
@@ -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
@@ -641,29 +641,36 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauses (wrapBinds, mWhe
             $ docLines
             $ map docSetBaseY
             $ clauseDocs
-            >>= \(grhsEpAnn, guardDocs, bodyDoc) -> -- TODO92
-                  (case guardDocs of
-                      [] -> [docHandleComms grhsEpAnn docEmpty]
-                      [g] ->
-                        [ docHandleComms grhsEpAnn
-                        $ docSeq [appSep
-                        $ docLit $ Text.pack "|", return g]
-                        ]
-                      (g1 : gr) ->
-                        ( ( docHandleComms grhsEpAnn
-                          $ docSeq [appSep $ docLit $ Text.pack "|", return g1]
-                          )
-                        : (gr <&> \g ->
-                            docSeq [appSep $ docLit $ Text.pack ",", return g]
-                          )
-                        )
-                    )
-                    ++ [ docCols
-                           ColOpPrefix
-                           [ appSep $ return binderDoc
-                           , docAddBaseY BrIndentRegular $ return bodyDoc
-                           ]
-                       ]
+            >>= \(grhsEpAnn, guardDocs, bodyDoc) -> case guardDocs of
+              [] ->
+                [ docHandleComms grhsEpAnn
+                $ docCols
+                  ColOpPrefix
+                  [ appSep $ return binderDoc
+                  , docAddBaseY BrIndentRegular $ return bodyDoc
+                  ]
+                ]
+              [g] ->
+                [ docHandleComms grhsEpAnn
+                  $ docSeq [appSep $ docLit $ Text.pack "|", return g]
+                , docSeq
+                  [ appSep $ return binderDoc
+                  , docAddBaseY BrIndentRegular $ return bodyDoc
+                  ]
+                ]
+              (g1 : gr) ->
+                (  [ docHandleComms grhsEpAnn
+                     $ docSeq [appSep $ docLit $ Text.pack "|", return g1]
+                   ]
+                ++ (gr <&> \g ->
+                     docSeq [appSep $ docLit $ Text.pack ",", return g]
+                   )
+                ++ [ docSeq
+                     [ appSep $ return binderDoc
+                     , docAddBaseY BrIndentRegular $ return bodyDoc
+                     ]
+                   ]
+                )
           ]
         ++ wherePartMultiLine
 
@@ -799,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
@@ -823,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 ")"
          ]
 
@@ -876,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
 
@@ -124,19 +124,22 @@ layoutExpr lexpr@(L _ expr) = do
       docSetParSpacing
         $ docAddBaseY BrIndentRegular
         $ (docLit $ Text.pack "\\case {}")
-    HsLamCase _ (MG _ lmatches@(L _ matches) _) -> do
+    HsLamCase epAnn (MG _ lmatches@(L _ matches) _) -> do
       binderDoc   <- docLit $ Text.pack "->"
       layouters <- mAsk
       funcPatDocs <-
         layout_patternBind layouters Nothing binderDoc `mapM` matches
-      docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
-        (docLit $ Text.pack "\\case")
-        ( docSetBaseAndIndent
-        $ docNonBottomSpacing
-        $ docHandleComms lmatches
-        $ docLines
-        $ return <$> funcPatDocs
-        )
+      docSetParSpacing
+        $ docAddBaseY BrIndentRegular
+        $ docHandleComms epAnn
+        $ docPar
+          (docLit $ Text.pack "\\case")
+          ( docSetBaseAndIndent
+          $ docNonBottomSpacing
+          $ docHandleComms lmatches
+          $ docLines
+          $ return <$> funcPatDocs
+          )
     HsApp _ exp1 _ -> do
       let gather
             :: [(EpAnnCO, LHsExpr GhcPs)]
@@ -211,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
@@ -235,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
@@ -646,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
@@ -732,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
+              ]
+            , closeDoc
+            ]
           ]
-        FirstLast (_, e1) ems (finalCommaPos, eN) -> runFilteredAlternative $ do
+        FirstLast (_, _, e1) ems (finalCommaPos, _, eN) -> runFilteredAlternative $ do
           addAlternativeCond (not hasComments)
             $  docSeq
             $  [openDoc, docForceSingleline e1]
             ++ [ x
-               | (commaPos, e) <- ems
+               | (commaPos, _, e) <- ems
                , x <- [docHandleComms commaPos docCommaSep, docForceSingleline e]
                ]
             ++ [ docHandleComms finalCommaPos docCommaSep
@@ -750,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
@@ -1015,7 +1003,7 @@ recordExpression dotdot wrapO wrapDD wrapC indentPolicy _lexpr nameDoc nameLayou
                   [AddCommaAnn span] -> Just $ epaLocationRealSrcSpanStart span
                   _                  -> Nothing
                 SrcSpanAnn EpAnnNotUsed _ -> Nothing
-          fnameDoc <- shareDoc $ nameLayouter nameThing
+          fnameDoc <- shareDoc $ docHandleComms fEpAnn $ nameLayouter nameThing
           if pun
             then pure $ Left (posStart, fnameDoc)
             else do

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,130 +12,142 @@ 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)) | hasParen == NoParen && null opExprList -> do
+    let AnnParen _ spanOpen spanClose = anns epAnn
+    let mergePoses locMay span = case locMay of
+          Nothing  -> Just (epaLocationRealSrcSpanStart span)
+          Just loc -> Just (min (epaLocationRealSrcSpanStart span) loc)
+    gatherOpTreeE ParenNoSpace
+                  (hasComms || hasAnyCommentsBelow epAnn)
+                  (commWrap . docHandleComms epAnn)
+                  (mergePoses locOpen spanOpen)
+                  (mergePoses locClose spanClose)
+                  []
+                  inner
   (L _ (HsPar epAnn inner)) -> do
     let AnnParen _ spanOpen spanClose = anns epAnn
     let mergePoses locMay span = case locMay of
           Nothing  -> Just (epaLocationRealSrcSpanStart span)
           Just loc -> Just (min (epaLocationRealSrcSpanStart span) loc)
     (innerTree, innerHasComms) <-
-      gatherOpTreeE True
+      gatherOpTreeE ParenNoSpace
                     (hasComms || hasAnyCommentsBelow epAnn)
                     (commWrap . docHandleComms epAnn)
                     (mergePoses locOpen spanOpen)
                     (mergePoses locClose spanClose)
                     []
                     inner
-    if null opExprList
-      then pure (innerTree, innerHasComms)
-      else do
-        numberedRights <- opExprList `forM` \(x, y) -> do
-          x' <- x
-          y' <- y
-          pure (x', y')
-        pure
-          $ ( OpUnknown hasParen locOpen locClose innerTree numberedRights
-            , innerHasComms
-            )
-  final -> do
-    numberedLeft   <- commWrap $ callLayouter layout_expr final
-    numberedRights <- opExprList `forM` \(x, y) -> do
-      x' <- x
-      y' <- y
-      pure (x', y')
+    -- if null opExprList
+    --   then pure (innerTree, innerHasComms)
+    --   else do
+    numberedRights <-
+      opExprList
+      `forM` \(x, y) -> do
+               x' <- x
+               pure (x', y)
     pure
-      $ ( OpUnknown hasParen
-                    locOpen
-                    locClose
-                    (OpLeaf $ numberedLeft)
-                    numberedRights
+      $ ( OpUnknown hasParen locOpen locClose innerTree numberedRights
+        , innerHasComms
+        )
+  final | hasParen == NoParen && null opExprList -> do
+    tree <- commWrap $ callLayouter layout_expr final
+    pure (OpLeaf tree, hasComms)
+  final@(L _ inner) -> do
+    numberedLeft   <- commWrap $ callLayouter layout_expr final
+    numberedRights <-
+      opExprList
+      `forM` \(x, y) -> do
+               x' <- x
+               pure (x', y)
+    pure
+      $ ( OpUnknown
+            (case (hasParen, inner) of
+              (NoParen, _              ) -> NoParen
+              (_      , ExplicitTuple{}) -> ParenWithSpace
+              _                          -> hasParen
+            )
+            locOpen
+            locClose
+            (OpLeaf $ numberedLeft)
+            numberedRights
         , hasComms
         )
 
 gatherOpTreeT
-  :: Bool
+  :: OpParenMode
   -> Bool
   -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered)
   -> Maybe GHC.RealSrcLoc
   -> Maybe GHC.RealSrcLoc
-  -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)]
+  -> [(ToBriDocM BriDocNumbered, OpTree)]
   -> LHsType GhcPs
   -> ToBriDocM (OpTree, Bool)
 gatherOpTreeT hasParen hasComms commWrap locOpen locClose opExprList = \case
-  (L _ (HsOpTy NoExtField l1 op1 r1)) ->
+  (L _ (HsOpTy NoExtField l1 op1 r1)) -> do
+    inner <- callLayouter2 layout_type False r1
     gatherOpTreeT
-      hasParen
+      (case hasParen of
+        NoParen -> NoParen
+        _       -> ParenWithSpace
+      )
       hasComms
       commWrap
       locOpen
       locClose
-      ( (docLit $ printRdrNameWithAnns op1, callLayouter layout_type r1)
+      ( (docLit $ printRdrNameWithAnns op1, OpLeaf inner)
       : opExprList
       )
       l1
-  (L _ (HsParTy epAnn inner)) -> do
-    let AnnParen _ spanOpen spanClose = anns epAnn
-    let mergePoses locMay span = case locMay of
-          Nothing  -> Just (epaLocationRealSrcSpanStart span)
-          Just loc -> Just (min (epaLocationRealSrcSpanStart span) loc)
-    (innerTree, innerHasComms) <-
-      gatherOpTreeT True
-                    (hasComms || hasAnyCommentsBelow epAnn)
-                    (commWrap . docHandleComms epAnn)
-                    (mergePoses locOpen spanOpen)
-                    (mergePoses locClose spanClose)
-                    []
-                    inner
-    if null opExprList
-      then pure (innerTree, innerHasComms)
-      else do
-        numberedRights <- opExprList `forM` \(x, y) -> do
-          x' <- x
-          y' <- y
-          pure (x', y')
-        pure
-          $ ( OpUnknown hasParen locOpen locClose innerTree numberedRights
-            , innerHasComms
-            )
-  final -> do
-    numberedLeft   <- commWrap $ callLayouter layout_type final
-    numberedRights <- opExprList `forM` \(x, y) -> do
-      x' <- x
-      y' <- y
-      pure (x', y')
+  final@(L _ inner) -> do
+    numberedLeft   <- commWrap $ callLayouter2 layout_type False final
+    numberedRights <-
+      opExprList
+      `forM` \(x, y) -> do
+               x' <- x
+               pure (x', y)
     pure
-      $ ( OpUnknown hasParen
-                    locOpen
-                    locClose
-                    (OpLeaf $ numberedLeft)
-                    numberedRights
+      $ ( OpUnknown
+            (case (hasParen, inner) of
+              (NoParen, _          ) -> NoParen
+              (_      , HsTupleTy{}) -> ParenWithSpace
+              _                      -> hasParen
+            )
+            locOpen
+            locClose
+            (OpLeaf $ numberedLeft)
+            numberedRights
         , hasComms
         )
 
@@ -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
+      let zeroOps       = null sharedOps
+          spaceAfterPar = not zeroOps
+          wrapParenIfSl x inner = if x == NoParen
+            then docSetParSpacing inner
+            else wrapParenSl inner
           wrapParenSl inner = docAlt
             [ docSeq
               [ docLit $ Text.pack "("
@@ -242,24 +332,44 @@ 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 = docSetBaseY $ docLines
-            (  [ docCols
-                   ColOpPrefix
-                   [ (if zeroOps then id else appSep) $ docLit $ Text.pack "("
-                   , docHandleComms locO $ innerHead
-                   ]
-               ]
-            ++ innerLines
-            ++ [docHandleComms locC $ docLit $ Text.pack ")"]
-            )
+          wrapParenMlIf x innerHead innerLines = case x of
+            NoParen        -> docPar innerHead (docLines innerLines)
+            ParenWithSpace -> wrapParenMl True innerHead innerLines
+            ParenNoSpace   -> wrapParenMl False innerHead innerLines
+          wrapParenMl space innerHead innerLines = docAlt
+            [ docForceZeroAdd $ docSetBaseY $ docLines
+              ( [ docCols
+                    ColOpPrefix
+                    [ (if spaceAfterPar || space then appSep else id)
+                    $ docLit
+                    $ Text.pack "("
+                    , docHandleComms locO $ innerHead
+                    ]
+                ]
+              ++ innerLines
+              ++ [docHandleComms locC $ docLit $ Text.pack ")"]
+              )
+            , docPar
+              (docCols
+                ColOpPrefix
+                [ (if spaceAfterPar || space then appSep else id)
+                $ docLit
+                $ Text.pack "("
+                , docHandleComms locO $ innerHead
+                ]
+              )
+              ( docLines
+              $ innerLines ++ [docHandleComms locC $ docLit $ Text.pack ")"]
+              )
+            ]
 
       configAllowsParInsert <- askLayoutConf _lconfig_fixityBasedAddAlignParens
-      let allowParIns = configAllowsParInsert && case fixity of
-            Nothing                -> False
-            Just (Fixity _ prec _) -> prec > 0
+      let allowParIns =
+            (  configAllowsParInsert
+            && case fixity of
+                 Nothing                -> False
+                 Just (Fixity _ prec _) -> prec > 0
+            )
 
       let isSingleOp = length sharedOps == 1 && length sharedOpsFlat == 1
 
@@ -272,39 +382,40 @@ layoutOpTree allowSinglelinePar = \case
           $ wrapParenIfSl hasParen
           $ docSetParSpacing
           $ docSeq
-              ([docForceSingleline docL] ++ case splitFirstLast sharedOpsFlat of
-                FirstLastEmpty -> []
-                FirstLastSingleton (od, ed) ->
-                  [ docSeparator
-                  , docForceSingleline od
-                  , docSeparator
-                  , lastWrap ed
-                  ]
-                FirstLast (od1, ed1) ems (odN, edN) ->
-                  (  [ docSeparator
-                     , docForceSingleline od1
+              ( [docForceSingleline docL]
+              ++ case splitFirstLast sharedOpsFlat of
+                   FirstLastEmpty -> []
+                   FirstLastSingleton (od, ed) ->
+                     [ docSeparator
+                     , docForceSingleline od
                      , docSeparator
-                     , docForceSingleline ed1
+                     , lastWrap ed
                      ]
-                  ++ join
-                       [ [ docSeparator
-                         , docForceSingleline od
-                         , docSeparator
-                         , docForceSingleline ed
-                         ]
-                       | (od, ed) <- ems
-                       ]
-                  ++ [ docSeparator
-                     , docForceSingleline odN
-                     , docSeparator
-                     , lastWrap edN
-                     ]
-                  )
+                   FirstLast (od1, ed1) ems (odN, edN) ->
+                     (  [ docSeparator
+                        , docForceSingleline od1
+                        , docSeparator
+                        , docForceSingleline ed1
+                        ]
+                     ++ join
+                          [ [ docSeparator
+                            , docForceSingleline od
+                            , docSeparator
+                            , docForceSingleline ed
+                            ]
+                          | (od, ed) <- ems
+                          ]
+                     ++ [ docSeparator
+                        , docForceSingleline odN
+                        , docSeparator
+                        , lastWrap edN
+                        ]
+                     )
               )
         -- 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]
@@ -318,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])
@@ -327,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]
@@ -341,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
-      Nothing         -> pure (id, [])
+    (wrapCtx  , cntxtDocs) <- case ctxMay of
+      Nothing                            -> pure (id, [])
       Just (L (SrcSpanAnn epAnn _) ctxs) -> do
-        let wrap = case epAnn of
-              EpAnn _ (AnnContext (Just (_, loc)) _ _) _ ->
-                docFlushCommsPost False (Just $ epaLocationRealSrcSpanStart loc)
-                  . docHandleComms epAnn
-              _ -> docHandleComms epAnn
-        x <- ctxs `forM` (shareDoc . layoutType)
+        let
+          wrap = case epAnn of
+            EpAnn _ (AnnContext (Just (_, loc)) _ _) _ ->
+              docFlushCommsPost False (Just $ epaLocationRealSrcSpanStart loc)
+                . docHandleComms epAnn
+            _ -> docHandleComms epAnn
+        x <- ctxs `forM` (shareDoc . layoutType False)
         pure (wrap, x)
-    pure
-      $ ( wrapCtx $ case cntxtDocs of
-            []   -> docLit $ Text.pack "()"
-            [x]  -> x
-            docs -> docAlt
-              [ let
-                  open  = docLit $ Text.pack "("
-                  close = docLit $ Text.pack ")"
-                  list =
-                    List.intersperse docCommaSep $ docForceSingleline <$> docs
-                in
-                  docSeq ([open] ++ list ++ [close])
-              , let open = docCols
-                      ColTyOpPrefix
-                      [ docParenLSep
-                      , docAddBaseY (BrIndentSpecial 2) $ head docs
-                      ]
-                    close = docLit $ Text.pack ")"
-                    list  = List.tail docs <&> \cntxtDoc -> docCols
-                      ColTyOpPrefix
+    outerHead <- wrapCtx $ case cntxtDocs of
+      []   -> docLit $ Text.pack "()"
+      [x]  -> x
+      docs -> docAlt
+        [ let
+              open  = docLit $ Text.pack "("
+              close = docLit $ Text.pack ")"
+              list  = List.intersperse docCommaSep $ docForceSingleline <$> docs
+          in  docSeq ([open] ++ list ++ [close])
+        , let
+            open =
+              docCols
+                ColTyOpPrefix
+                [docParenLSep
+                             , docAddBaseY (BrIndentSpecial 2) $ head docs
+                                                                          ]
+            close = docLit $ Text.pack ")"
+            list  = List.tail docs <&> \cntxtDoc ->
+              docCols ColTyOpPrefix
                       [docCommaSep, docAddBaseY (BrIndentSpecial 2) cntxtDoc]
-                in  docPar open $ docLines $ list ++ [close]
-              ]
-        , (("=>", innerHead) : innerBody)
-        )
+          in
+            docPar open $ docLines $ list ++ [close]
+        ]
+    arrowDoc <- docLitS "=>"
+    pure (OpLeaf outerHead, (arrowDoc, innerHead) : innerBody)
   HsFunTy epAnn _ typ1 typ2 -> do
     (typ1Doc, (innerHead, innerBody)) <- do
       let
@@ -89,71 +93,92 @@ splitArrowType ltype@(L _ typ) = case typ of
           EpAnn _ AddLollyAnnU{} _ ->
             error "brittany internal error: HsFunTy EpAnn"
           EpAnnNotUsed -> id
-      typ1Doc   <- docHandleComms epAnn $ wrapper $ layoutType typ1
+      typ1Doc   <- docHandleComms epAnn $ wrapper $ layoutType False typ1
       typ2Tuple <- splitArrowType typ2
       pure (typ1Doc, typ2Tuple)
-    pure $ (pure typ1Doc, ("->", innerHead) : innerBody)
-  _ -> 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
-        tyVarDocs <- layoutTyVarBndrs binders
-        docAlt
-          -- :: forall x
-          --  . x
-          [ let open = docLit $ Text.pack "forall"
-            in  docSeq (open : processTyVarBndrsSingleline tyVarDocs)
-          -- :: forall
-          --      (x :: *)
-          --  . x
-          , docPar
-            (docLit (Text.pack "forall"))
-            (docLines $ tyVarDocs <&> \case
-              (tname, Nothing) ->
-                docEnsureIndent BrIndentRegular $ docLit tname
-              (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines
-                [ docCols ColTyOpPrefix [docParenLSep, docLit tname]
-                , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc]
-                , docLit $ Text.pack ")"
-                ]
-            )
-          ]
-      , (".", innerHead) : innerBody
-      )
-
-
-joinSplitArrowType
-  :: Bool
-  -> (ToBriDocM BriDocNumbered, [(String, ToBriDocM BriDocNumbered)])
-  -> ToBriDocM BriDocNumbered
-joinSplitArrowType hasComments (dHead, body) =
-  runFilteredAlternative $ do
-    addAlternativeCond (not hasComments)
-      $ docForceSingleline $ docSeq $ dHead : join
-        [ [docSeparator, docLit (Text.pack prefix), docSeparator, doc]
-        | (prefix, doc) <- body
-        ]
-    addAlternative $ docPar (docSetBaseY dHead) $ docLines
-      [ docCols
-          ColTyOpPrefix
-          [ appSep $ docLit $ Text.pack $ if length prefix < 2
-            then " " ++ prefix -- special case for "forall dot"
-                               -- in multi-line layout case
-            else prefix
-          , docEnsureIndent (BrIndentSpecial (length prefix + 1)) doc
-          ]
-      | (prefix, doc) <- body
+  outerHead <- do
+    tyVarDocs <- layoutTyVarBndrs binders
+    docAlt
+      -- :: forall x
+      --  . x
+      [ let open = docLit $ Text.pack "forall"
+        in  docSeq (open : processTyVarBndrsSingleline tyVarDocs)
+      -- :: forall
+      --      (x :: *)
+      --  . x
+      , docPar
+        (docLit (Text.pack "forall"))
+        (docLines $ tyVarDocs <&> \case
+          (tname, Nothing) ->
+            docEnsureIndent BrIndentRegular $ docLit tname
+          (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines
+            [ docCols ColTyOpPrefix [docParenLSep, docLit tname]
+            , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc]
+            , docLit $ Text.pack ")"
+            ]
+        )
       ]
+  dotDoc <- docLitS "."
+  pure (OpLeaf outerHead, (dotDoc, innerHead) : innerBody)
 
-layoutType :: ToBriDoc HsType
-layoutType ltype@(L _ typ) = docHandleComms ltype $ case typ of
+layoutSplitArrowType
+  :: (OpTree, [(BriDocNumbered, OpTree)])
+  -> Bool
+  -> ToBriDocM BriDocNumbered
+layoutSplitArrowType (headPart, restParts) hasComments = do
+  layouters <- mAsk
+  let opTree =
+        OpKnown NoParen
+                Nothing
+                Nothing
+                (Fixity NoSourceText (-1) InfixN)
+                headPart
+                restParts
+  layout_opTree layouters (opTree, hasComments)
+
+
+layoutType :: Bool -> ToBriDoc HsType
+layoutType forceHasComms ltype@(L _ typ) = docHandleComms ltype $ case typ of
   -- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible"
   HsTyVar epAnn promoted name -> docHandleComms epAnn $ do
     t <- lrdrNameToTextAnnTypeEqualityIsSpecial name
@@ -162,34 +187,20 @@ layoutType ltype@(L _ typ) = docHandleComms ltype $ case typ of
       NotPromoted -> docHandleComms name $ docLit t
   HsForAllTy{} -> do
     parts <- splitArrowType ltype
-    joinSplitArrowType (hasAnyCommentsBelow typ) parts
+    layoutSplitArrowType parts (hasAnyCommentsBelow typ || forceHasComms)
   HsQualTy{} -> do
     parts <- splitArrowType ltype
-    joinSplitArrowType (hasAnyCommentsBelow typ) parts
+    layoutSplitArrowType parts (hasAnyCommentsBelow typ || forceHasComms)
   HsFunTy{} -> do
     parts <- splitArrowType ltype
-    joinSplitArrowType (hasAnyCommentsBelow typ) parts
-  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/T1_Alt.hs

@@ -205,7 +205,7 @@ transformAlts =
         let ind = _acp_indent acp + _acp_indentPrep acp + indAdd
         mSet $ acp
           { _acp_indent = ind, _acp_indentPrep = 0
-          , _acp_indentPrepForced = False
+          , _acp_indentPrepForced = parentForced
           }
         sameLine' <- go sameLine
         mModify $ \acp' -> acp'

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/T4_Columns.hs

@@ -91,8 +91,8 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
       ]
   BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1 == sig2 ->
     Just $ BDAddBaseY ind (BDLines [col1, col2])
-  BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _) : rest))
-    | sig1 == sig2 -> Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest)
+  -- BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _) : rest))
+  --   | sig1 == sig2 -> Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest)
   BDPar ind (BDLines lines1) col2@(BDCols sig2 _)
     | BDCols sig1 _ <- List.last lines1, sig1 == sig2 -> Just
     $ BDAddBaseY ind (BDLines $ lines1 ++ [col2])
@@ -109,15 +109,13 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
     -> Just
       $ BDLines [BDCols sig1 (List.init cols ++ [line]), BDCols sig2 cols2]
   BDCols sig1 cols
-    | BDPar ind line (BDLines lines) <- List.last cols
-    , BDCols sig2 cols2 <- List.last lines
-    , sig1 == sig2
-    -> Just $ BDLines
-      [ BDCols sig1
-      $ List.init cols
-      ++ [BDPar ind line (BDLines $ List.init lines)]
-      , BDCols sig2 cols2
-      ]
+    | BDPar _ line (BDLines lines) <- List.last cols
+    , all (\case
+            BDCols sig2 _ -> sig1 == sig2
+            _ -> False
+          )
+          lines
+    -> Just $ BDLines $ BDCols sig1 (List.init cols ++ [line]) : lines
   BDLines [x] -> Just $ x
   BDLines [] -> Just $ BDEmpty
   BDSeq{} -> Nothing

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
@@ -44,10 +49,16 @@ transformSimplifyIndent = Uniplate.rewrite $ \case
     Just $ BDFlushCommentsPrior c (BDAddBaseY i x)
   BDAddBaseY i (BDFlushCommentsPost c sm x) ->
     Just $ BDFlushCommentsPost c sm (BDAddBaseY i x)
+  BDAddBaseY i (BDQueueComments comms x) ->
+    Just $ BDQueueComments comms (BDAddBaseY i x)
   BDAddBaseY i (BDSeq l) ->
     Just $ BDSeq $ List.init l ++ [BDAddBaseY i $ List.last l]
   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

@@ -24,6 +24,7 @@ import           GHC                            ( Anno
                                                 , ParsedSource
                                                 , XRec
                                                 , LImportDecl
+                                                , LEpaComment
                                                 )
 import GHC.Utils.Outputable(Outputable)
 import Language.Haskell.Brittany.Internal.Config.Types
@@ -89,6 +90,8 @@ finalToList_ :: FinalList a () -> [a]
 finalToList_ (FinalList l) = l (:) (\() -> [])
 finalToList :: FinalList a b -> ([a], b)
 finalToList (FinalList l) = l (\x (a, b) -> (x:a, b)) (\b -> ([], b))
+concatMapFinal :: FinalList a () -> (a -> [b]) -> [b]
+concatMapFinal (FinalList l) f = l (\x rest -> f x ++ rest) (\() -> [])
 
 instance Functor (FinalList a) where
   fmap = _finalRMap
@@ -119,7 +122,7 @@ data ModuleElement
     -- ^ an import decl, only occurs if pretty-printing the module head.
   | MEDecl (LHsDecl GhcPs) [(Int, EpaCommentTok)]
     -- ^ a top-level declaration
-  | MEComment (Int, EpaCommentTok)
+  | MEComment (Int, LEpaComment)
     -- ^ a top-level comment, i.e. a comment located between top-level elements
     --   (and not associated to some nested node, which might in theory happen).
     --   The Int carries the indentation of the comment.
@@ -157,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
@@ -177,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
@@ -273,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/Internal/WriteBriDoc/Operators.hs

@@ -25,6 +25,7 @@ where
 
 import Language.Haskell.Brittany.Internal.Prelude
 
+import qualified Data.Maybe
 import qualified Data.Text                     as Text
 import qualified Data.Text.Lazy.Builder        as Text.Builder
 import qualified GHC.OldList                   as List
@@ -157,7 +158,9 @@ layoutWriteComment absolute isBlock dp commentLines s = do -- TODO92 we don't mo
         PlannedNewline l ->
           if l <= y then PlannedSameline 1 else PlannedNewline (l - y)
         PlannedDelta l i ->
-          if l <= y then PlannedSameline 1 else PlannedDelta (l - y) i
+          if l <= y && Data.Maybe.isNothing (_lstate_markerForDelta state)
+            then PlannedSameline 1
+            else PlannedDelta (l - y) i
       else case _lstate_plannedSpace state of
         PlannedNone        -> PlannedDelta 1 (_lstate_curY state)
         PlannedSameline i  -> PlannedDelta 1 (_lstate_curY state + i)

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,129 +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
-        (inlineConf, perItemConf) <- do
-          resE <-
-            liftIO $ ExceptT.runExceptT $ extractCommentConfigs putErrorLnIO parsedSource
-          case resE of
-            Left (err, input) -> do
-              putErrorLn $ "Error: parse error in inline configuration:"
-              putErrorLn err
-              putErrorLn $ "  in the string \"" ++ input ++ "\"."
-              ExceptT.throwE 61
-            Right c -> -- trace (showTree c) $
-              pure c
-        let moduleConf = cZipWith fromOptionIdentity config inlineConf
-        when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do
-          let val = printTreeWithCustom 160 customLayouterF parsedSource
-          putErrorLn ("---- ast ----\n" ++ show val)
-        let
-          disableFormatting =
-            moduleConf & _conf_disable_formatting & confUnpack
-        (errsWarns, outSText, hasChanges) <- do
-          if
-            | disableFormatting -> do
-              pure ([], originalContents, False)
-            | exactprintOnly -> do
-              let r = Text.pack $ ExactPrint.exactPrint parsedSource
-              pure ([], r, r /= originalContents)
-            | otherwise -> do
-              let
-                omitCheck =
-                  moduleConf
-                    & _conf_errorHandling
-                    .> _econf_omit_output_valid_check
-                    .> confUnpack
-              (ews, outRaw) <- if hasCPP || omitCheck
-                then liftIO $ processModule (TraceFunc putErrorLnIO) moduleConf perItemConf parsedSource
-                else liftIO
-                  $ pPrintModuleAndCheck (TraceFunc putErrorLnIO) moduleConf perItemConf parsedSource
-              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)
+        pure $ Right inputString
+      Just p -> pure $ Left p
+    let
+      printErrorsAndWarnings errsWarns = do
         let
           customErrOrder ErrorInput{} = 4
           customErrOrder LayoutWarning{} = -1 :: Int
@@ -501,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
@@ -533,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 =