brittany.cabal

@@ -170,8 +170,6 @@ test-suite brittany-test-suite
 
   build-depends:
     , hspec >= 2.8.3 && < 2.10
-    , HUnit >= 1.6.2 && < 1.7
-    , ansi-terminal >= 0.11.4 && < 0.12
     , parsec ^>= 3.1.14
     , these ^>= 1.1
   hs-source-dirs: source/test-suite

data/10-structured/op-precedence.blt

@@ -145,7 +145,7 @@ doop =
 #expected
 doop =
   some long invocation == loooooooooongman + (third nested expression) - 4
-    && {- meow -}  5 - 6 > 7 `mod` loooooooooongwoman
+    && {- meow -} 5 - 6 > 7 `mod` loooooooooongwoman
     || ill just invoke a function with these args
     || foo
        && dooasdoiaosdoi ** oaisdoioasido
@@ -165,7 +165,7 @@ doop =
 -- brittany { lconfig_fixityBasedAddAlignParens: True }
 doop =
   (  (  some long invocation == loooooooooongman + (third nested expression) - 4
-     && {- meow -}  5 - 6 > 7 `mod` loooooooooongwoman
+     && {- meow -} 5 - 6 > 7 `mod` loooooooooongwoman
      )
   || ill just invoke a function with these args
   || (  foo

data/11-extensions/datakinds.blt

@@ -57,9 +57,9 @@ test = Proxy @'[{- comment -} 'True ]
 #test with-comment-4
 test
   :: Proxy '[{- comment -}
-              'True ]
+                           'True ]
 test = Proxy @'[{- comment -}
-                 'True ]
+                              'True ]
 
 #test with-comment-5
 test
@@ -69,9 +69,9 @@ test = Proxy @'[{- comment -} True]
 #test with-comment-6
 test
   :: Proxy '[{- comment -}
-             True]
+                           True]
 test = Proxy @'[{- comment -}
-                True]
+                              True]
 
 #test explicit-list-type non-promoted
 type Foo = '[Bool, Bool, Bool]

data/15-regressions.blt

@@ -329,13 +329,11 @@ func =
                                         foooooooooooooooooooooooooooooooo
 
 #test opapp-specialcasing-3
-func =
+func = fooooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo
-  fooooooooooooooooooooooooooooooooo
+  [ foooooooooooooooooooooooooooooooo
-    + foooooooooooooooooooooooooooooooo
+  , foooooooooooooooooooooooooooooooo
-        [ foooooooooooooooooooooooooooooooo
+  , foooooooooooooooooooooooooooooooo
-        , foooooooooooooooooooooooooooooooo
+  ]
-        , foooooooooooooooooooooooooooooooo
-        ]
 
 #test opapp-indenting
 parserPrim =
@@ -958,43 +956,3 @@ func = other $ meep
   [q|hello
      world|]
   (some other very long linnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnne)
-
-#test multiline-lambda-whitespace
-func =
-  Text.intercalate
-    "\n"
-    (   (\(abc, def) ->
-           abc ++ def ++ "lkajsdljkasdlkjasldjkljkasd" ++ asdasdasdasd
-        )
-    <$> mylist
-    )
-
-#test operator newline behaviour
-func =
-  fromIntegral aaaaaaaaaaaaaaaaaaa
-    / fromIntegral (aaaaaaaaaaaaaaaaaaa + bbbbbbbbbbbbbbbbbb)
-
-#test multi-constructor associated data decl
-data POtfuggj
-instance BMGuwigoc POtfuggj where
-  data KVeeweknc POtfuggj r
-    = ILpieakli
-    | USilcnhkYaraposqu (WeyOoovf (Nubwlhtjd EculdW.QaeopznkAc r))
-    deriving stock (Lirylfj1, Jexr)
-    deriving anyclass Qart2.Vrzxuvcf
-
-#test bang-type
-data LabeledBool = LabeledBool !Int !Bool
-
-#test block-comment after let
-func = do
-  let cipInuihz = Vuozczdm.yhEfun tuhiuRasohy
-  let {- CAZEB mecwbd "Caa ||" -}
-      doeeRbaviceQzymin a b = olivhuwqbaq
-      iqnz biwomeJhhujy _ _ | biwomeJhhujy < volpoqAsizmHdwpl = pure 0
-  pure True
-
-#test comment-inside-decl
-func False = 0
--- comment
-func True  = 1

data/30-tests-context-free.blt

@@ -1278,13 +1278,11 @@ func =
         foooooooooooooooooooooooooooooooo
 
 #test opapp-specialcasing-3
-func =
+func = fooooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo
-  fooooooooooooooooooooooooooooooooo
+  [ foooooooooooooooooooooooooooooooo
-    + foooooooooooooooooooooooooooooooo
+  , foooooooooooooooooooooooooooooooo
-        [ foooooooooooooooooooooooooooooooo
+  , foooooooooooooooooooooooooooooooo
-        , foooooooooooooooooooooooooooooooo
+  ]
-        , foooooooooooooooooooooooooooooooo
-        ]
 
 #test opapp-indenting
 parserPrim =

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

@@ -10,8 +10,6 @@ module Language.Haskell.Brittany.Internal
    -- re-export from utils:
   , extractCommentConfigs
   , TraceFunc(TraceFunc)
-  , Splitting.splitModuleDecls
-  , Splitting.extractDeclMap
   )
 where
 
@@ -19,6 +17,7 @@ import           Control.Monad.Trans.Except
 import           Data.CZipWith
 import qualified Data.Text                     as Text
 import qualified Data.Text.Lazy                as TextL
+import qualified GHC                     hiding ( parseModule )
 import qualified GHC.Driver.Session            as GHC
 import           GHC.Hs
 import qualified GHC.LanguageExtensions.Type   as GHC
@@ -30,8 +29,6 @@ import           Language.Haskell.Brittany.Internal.S3_ToBriDocTools
 import           Language.Haskell.Brittany.Internal.Prelude
 import qualified Language.Haskell.Brittany.Internal.S1_Parsing
                                                as Parsing
-import qualified Language.Haskell.Brittany.Internal.S2_SplitModule
-                                               as Splitting
 import           Language.Haskell.Brittany.Internal.StepOrchestrate
                                                 ( processModule )
 import           Language.Haskell.Brittany.Internal.Types
@@ -82,13 +79,9 @@ parsePrintModule traceFunc configWithDebugs inputText = runExceptT $ do
     case parseResult of
       Left  err -> throwE [ErrorInput err]
       Right x   -> pure x
-  let moduleElementList = Splitting.splitModuleDecls parsedSource
   (inlineConf, perItemConf) <-
     mapExceptT (fmap $ bimap (\(a, b) -> [ErrorMacroConfig a b]) id)
-      $ extractCommentConfigs
+      $ extractCommentConfigs (useTraceFunc traceFunc) parsedSource
-        (useTraceFunc traceFunc)
-        (Splitting.extractDeclMap parsedSource)
-        moduleElementList
   let moduleConfig = cZipWith fromOptionIdentity config inlineConf
   let disableFormatting =
         moduleConfig & _conf_disable_formatting & confUnpack
@@ -103,12 +96,11 @@ parsePrintModule traceFunc configWithDebugs inputText = runExceptT $ do
                 & _econf_omit_output_valid_check
                 & confUnpack
         (ews, outRaw) <- if hasCPP || omitCheck
-          then lift
+          then lift $ processModule traceFunc moduleConfig perItemConf parsedSource
-            $ processModule traceFunc moduleConfig perItemConf moduleElementList
           else lift $ pPrintModuleAndCheck traceFunc
                                            moduleConfig
                                            perItemConf
-                                           moduleElementList
+                                           parsedSource
         let hackF s = fromMaybe s
               $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
         pure $ if hackAroundIncludes
@@ -142,17 +134,17 @@ pPrintModuleAndCheck
   :: TraceFunc
   -> Config
   -> PerItemConfig
-  -> FinalList ModuleElement p
+  -> GHC.ParsedSource
   -> IO ([BrittanyError], TextL.Text)
-pPrintModuleAndCheck traceFunc conf inlineConf moduleElementList = do
+pPrintModuleAndCheck traceFunc conf inlineConf parsedModule = do
   let ghcOptions     = conf & _conf_forward & _options_ghc & runIdentity
-  (errs, output) <- processModule traceFunc conf inlineConf moduleElementList
+  (errs, output) <- processModule traceFunc conf inlineConf parsedModule
   parseResult <- Parsing.parseModuleFromString ghcOptions
                                                "output"
                                                (\_ -> return $ Right ())
                                                (TextL.unpack output)
   let errs' = errs ++ case parseResult of
-        Left x  -> [ErrorOutputCheck x]
+        Left{}  -> [ErrorOutputCheck]
         Right{} -> []
   return (errs', output)
 
@@ -170,14 +162,10 @@ 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
+          $ extractCommentConfigs (\_ -> pure ()) parsedModule
-            (\_ -> pure ())
-            (Splitting.extractDeclMap parsedModule)
-            moduleElementList
       let moduleConf = cZipWith fromOptionIdentity conf inlineConf
       let omitCheck =
             conf
@@ -188,11 +176,11 @@ parsePrintModuleTests conf filename input = do
         then lift $ processModule (TraceFunc $ \_ -> pure ())
                                    moduleConf
                                    perItemConf
-                                   moduleElementList
+                                   parsedModule
         else lift $ pPrintModuleAndCheck (TraceFunc $ \_ -> pure ())
                                          moduleConf
                                          perItemConf
-                                         moduleElementList
+                                         parsedModule
       if null errs
         then pure $ TextL.toStrict $ ltext
         else throwE
@@ -207,7 +195,7 @@ parsePrintModuleTests conf filename input = do
     LayoutWarning str         -> str
     ErrorUnknownNode str _    -> str
     ErrorMacroConfig str _    -> "when parsing inline config: " ++ str
-    ErrorOutputCheck str      -> "Output is not syntactically valid: " ++ str
+    ErrorOutputCheck          -> "Output is not syntactically valid."
 -- this approach would for if there was a pure GHC.parseDynamicFilePragma.
 -- Unfortunately that does not exist yet, so we cannot provide a nominally
 -- pure interface.

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

@@ -64,8 +64,6 @@ keywords =
   , "proc"
   , "rec"
   , "family"
-  , "stock"
-  , "anyclass"
   ]
 
 extraKWs :: [String]

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

@@ -64,7 +64,6 @@ staticDefaultConfig = Config
     , _lconfig_fixityBasedAddAlignParens = coerce False
     , _lconfig_operatorParenthesisRefactorMode = coerce PRMKeep
     , _lconfig_operatorAllowUnqualify = coerce True
-    , _lconfig_allowSinglelineRecord = coerce True
     }
   , _conf_errorHandling = ErrorHandlingConfig
     { _econf_produceOutputOnErrors = coerce False
@@ -164,7 +163,7 @@ cmdlineConfigParser = do
       , _lconfig_allowSingleLineExportList = mempty
       , _lconfig_allowHangingQuasiQuotes = mempty
       , _lconfig_experimentalSemicolonNewlines = mempty
-      , _lconfig_allowSinglelineRecord     = mempty
+      -- , _lconfig_allowSinglelineRecord     = mempty
       , _lconfig_fixityAwareOps = mempty
       , _lconfig_fixityAwareTypeOps = mempty
       , _lconfig_fixityBasedAddAlignParens = mempty

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.Types
+import Language.Haskell.Brittany.Internal.Util.AST
 import Language.Haskell.Brittany.Internal.Config.Types.Instances1 ()
 import Language.Haskell.Brittany.Internal.Config.Types.Instances2 ()
 -- import Language.Haskell.Brittany.Internal.Utils
@@ -44,26 +44,46 @@ data InlineConfigTarget
 
 extractCommentConfigs
   :: (String -> IO ())
-  -> Map GHC.RealSrcSpan [String]
+  -> GHC.ParsedSource
-  -> FinalList ModuleElement a
   -> ExceptT (String, String) IO (CConfig Maybe, PerItemConfig)
-extractCommentConfigs _putErrorLn declMap moduleElementList = do
+extractCommentConfigs _putErrorLn modul = do
-  let comments = concatMapFinal (void moduleElementList) $ \case
+  let (L _ (GHC.HsModule modAnn _ _ _ _ decls _ _)) = modul
-        MEExactModuleHead modul -> case GHC.hsmodAnn $ GHC.unLoc modul of
+  let declMap :: Map GHC.RealSrcSpan [String]
-          GHC.EpAnn _ _ (GHC.EpaComments prior) -> prior
+      declMap = Map.fromList
-          GHC.EpAnn _ _ (GHC.EpaCommentsBalanced prior following) ->
+        [ ( case span of
-            prior ++ following
+            GHC.RealSrcSpan s _ -> s
-          GHC.EpAnnNotUsed -> []
+            GHC.UnhelpfulSpan _ -> error "unexpected UnhelpfulSpan"
-        MEPrettyModuleHead{}   -> []
+          , getDeclBindingNames decl
-        MEImportDecl{}         -> []
+          )
-        MEDecl{}               -> []
+        | decl <- decls
-        MEComment (_, comment) -> [comment]
+        , let (L (GHC.SrcSpanAnn _ span) _) = decl
-        MEWhitespace{}         -> []
+        ]
+  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)
   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 _) <- comments
+    | L anchr (EpaComment comm _) <- gatheredComments
     , Just line1                  <- case comm of
       EpaLineComment l ->
         [ List.stripPrefix "-- BRITTANY" l

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

@@ -135,14 +135,14 @@ data CLayoutConfig f = LayoutConfig
     -- The implementation for this is a bit hacky and not tested; it might
     -- break output syntax or not work properly for every kind of brace. So
     -- far I have considered `do` and `case-of`.
-  , _lconfig_allowSinglelineRecord :: f (Last Bool)
+  -- , _lconfig_allowSinglelineRecord :: f (Last Bool)
-    -- if true, layouts record data decls as a single line when possible, e.g.
+  --   -- if true, layouts record data decls as a single line when possible, e.g.
-    -- > MyPoint { x :: Double, y :: Double }
+  --   -- > MyPoint { x :: Double, y :: Double }
-    -- if false, always use the multi-line layout
+  --   -- if false, always use the multi-line layout
-    -- > MyPoint
+  --   -- > MyPoint
-    -- >   { x :: Double
+  --   -- >   { x :: Double
-    -- >   , y :: Double
+  --   -- >   , y :: Double
-    -- >   }
+  --   -- >   }
   , _lconfig_fixityAwareOps :: f (Last Bool)
     -- enables fixity-based layouting, e.g.
     -- > foo =

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

@@ -3,17 +3,15 @@
 -- TODO92
 
 module Language.Haskell.Brittany.Internal.S2_SplitModule
-  ( extractDeclMap
+  ( splitModule
-  , splitModuleDecls
+  )
-  , splitModuleStart
+where
-  ) where
 
 
 
 import           Language.Haskell.Brittany.Internal.Prelude
 
 import qualified Data.Generics                 as SYB
-import qualified Data.Map                      as Map
 import qualified GHC
 import           GHC                            ( AddEpAnn(AddEpAnn)
                                                 , Anchor(Anchor)
@@ -58,104 +56,88 @@ import           GHC.Parser.Annotation          ( DeltaPos
                                                   )
                                                 , EpaCommentTok(EpaEofComment)
                                                 )
-import           GHC.Types.SrcLoc               ( realSrcSpanEnd
+import           GHC.Types.SrcLoc               ( realSrcSpanEnd )
-                                                , realSrcSpanStart
-                                                )
 import qualified Language.Haskell.GHC.ExactPrint.Types
                                                as ExactPrint
 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
 import           Language.Haskell.Brittany.Internal.Types
-import           Language.Haskell.Brittany.Internal.Util.AST
 
 
 
-extractDeclMap :: GHC.ParsedSource -> Map GHC.RealSrcSpan [String]
+splitModule
-extractDeclMap modul =
+  :: Bool
-  Map.fromList
+  -> GHC.ParsedSource
-    [ ( case span of
+  -> Maybe GHC.RealSrcLoc
-          GHC.RealSrcSpan s _ -> s
+  -> FinalList ModuleElement ExactPrint.Pos
-          GHC.UnhelpfulSpan _ -> error "unexpected UnhelpfulSpan"
+splitModule shouldReformatHead lmod posWhere = do
-      , 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
+      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'
+      moduleWithoutComments =
-                                                , GHC.hsmodDecls = []
+        L moduleSpan modl { GHC.hsmodAnn = hsModAnn', GHC.hsmodDecls = [] }
-                                                }
+  lastSpan <- if shouldReformatHead
-  lastSpan <- do
+    then do
-    finalYield $ MEExactModuleHead moduleWithoutComments
+      finalYield $ MEPrettyModuleHead moduleWithoutComments
-    pure
+      let locBeforeImports =
-      $  maybe (1, 1) (ExactPrint.ss2posEnd)
+            maximumMay 
-      $  maximumMay
+              $  [ realSrcSpanEnd $ anchor a
-      $  [ GHC.anchor a
+                 | L a _ <- case hsModAnn' of
-         | L a _ <- GHC.priorComments $ case hsModAnn' of
+                   EpAnn _ _ (EpaComments cs             ) -> cs
-           EpAnn _ _ cs -> cs
+                   EpAnn _ _ (EpaCommentsBalanced cs1 cs2) -> cs1 ++ cs2
-           EpAnnNotUsed -> error "unexpected EpAnnNotUsed"
+                   EpAnnNotUsed -> error "unexpected EpAnnNotUsed"
-         ]
+                 ]
-      ++ [ s | AddEpAnn _ (EpaSpan s) <- GHC.am_main $ GHC.anns hsModAnn' ]
+              ++ [ pos | Just pos <- [posWhere] ]
-      ++ [ GHC.anchor a
+      let (importLines, lastSpan) = finalToList $ transformToImportLine
-         | L da _ <- GHC.hsmodImports modl
+            ( maybe 0 srcLocLine locBeforeImports
-         , L a  _ <- case GHC.ann da of
+            , maybe 1 srcLocCol  locBeforeImports
-           EpAnn _ _ (EpaComments l          ) -> l
+            )
-           EpAnn _ _ (EpaCommentsBalanced _ l) -> l
+            imports
-           EpAnnNotUsed                        -> []
+      let commentedImports = groupifyImportLines importLines
-         ]
+      sortCommentedImports commentedImports `forM_` \case
-      ++ [ span
+        EmptyLines n ->
-         | L (SrcSpanAnn _ (GHC.RealSrcSpan span _)) _ <- GHC.hsmodImports modl
+          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
   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
@@ -166,57 +148,52 @@ enrichComms lastSpanEnd = \case
       SameLine i        -> SameLine i
       DifferentLine l c -> DifferentLine (l - 1) c
     enrichComms (ExactPrint.ss2posEnd span) commRest
-  lcomm@(L (Anchor span _) _) : commRest -> do
+  (L (Anchor span _) (EpaComment comm _) : commRest) -> do
     case ExactPrint.ss2delta lastSpanEnd span of
       SameLine i -> do
-        finalYield $ MEComment (i, lcomm)
+        finalYield $ MEComment (i, comm)
       DifferentLine l c -> do
         finalYield $ MEWhitespace $ DifferentLine (l - 1) c
-        finalYield $ MEComment (0, lcomm)
+        finalYield $ MEComment (0, comm)
     enrichComms (ExactPrint.ss2posEnd span) commRest
 
 enrichDecls
   :: ExactPrint.Pos -> [LHsDecl GhcPs] -> FinalList ModuleElement ExactPrint.Pos
 enrichDecls lastSpanEnd = \case
   [] -> finalPure $ lastSpanEnd
-  ldecl@(L (SrcSpanAnn dAnn (GHC.RealSrcSpan span _)) _) : declRest ->
+  (L (SrcSpanAnn dAnn rlspan@(GHC.RealSrcSpan span _)) decl : declRest) ->
     case dAnn of
-      EpAnn _dAnchor _items (EpaComments _dComments) -> do
+      EpAnn dAnchor items (EpaComments dComments) -> do
         let
-          commentExtract
+          withoutComments =
-            :: [LEpaComment] -> WriterS.Writer [LEpaComment] [LEpaComment]
+            (L (SrcSpanAnn (EpAnn dAnchor items (EpaComments [])) rlspan) decl)
-          commentExtract comms = do
+          commentExtract = \case
-            let (innerComments, outerComments) =
+            L (GHC.Anchor anch _) EpaComment{} -> ExactPrint.ss2posEnd anch
-                  partition
+          -- It would be really nice if `ExactPrint.ss2posEnd span` was
-                    (\(L (Anchor anch _) _) ->
+          -- sufficient. But for some reason the comments are not
-                      (  realSrcSpanStart anch < realSrcSpanEnd span
+          -- (consistently) included in the length of the anchor. I.e.
-                      && realSrcSpanEnd anch > realSrcSpanStart span
+          -- 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.
-                    comms
+          -- We simply detect this here.
-            WriterS.tell outerComments
+          -- We probably do some redundant `SYB.everything` lookups
-            pure innerComments
+          -- throughout the code now. But optimizing it is not easy, and
-          (ldecl', extractedComments) = WriterS.runWriter
+          -- at worst it is larger constant factor on the size of the
-            $ SYB.everywhereM (SYB.mkM commentExtract) ldecl
+          -- input, so it isn't _that_ bad.
+          fixedSpanEnd = SYB.everything
+            max
+            (SYB.mkQ (ExactPrint.ss2posEnd span) commentExtract)
+            decl
         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 dComments)
-        let (afterComms, span2) = finalToList
+        let (immediate, later) = List.span (\case
-              $ enrichComms fixedSpanEnd
+              MEComment{} -> True
-                            (List.sortOn (\(L l _) -> l) extractedComments)
+              _ -> False
-        let (immediate, later) =
+              ) afterComms
-              List.span
+        finalYield $ MEDecl withoutComments [ comm | MEComment comm <- immediate ]
-                (\case
-                  MEComment{} -> True
-                  _           -> False
-                )
-                afterComms
-        finalYield
-          $ MEDecl
-            ldecl'
-            [ (ind, GHC.ac_tok comm) | MEComment (ind, L _ comm) <- immediate ]
         later `forM_` finalYield
         enrichDecls span2 declRest
       EpAnn _anchor _items (EpaCommentsBalanced{}) ->
@@ -230,8 +207,8 @@ enrichDecls lastSpanEnd = \case
 
 data ImportLine
   = EmptyLines Int
-  | SamelineComment (Int, LEpaComment)
+  | SamelineComment (Int, EpaCommentTok)
-  | NewlineComment  (Int, LEpaComment) -- indentation and comment
+  | NewlineComment  (Int, EpaCommentTok) -- indentation and comment
   | ImportStatement ImportStatementRecord
 
 instance Show ImportLine where
@@ -244,10 +221,10 @@ instance Show ImportLine where
         (length $ commentsAfter r)
 
 data ImportStatementRecord = ImportStatementRecord
-  { commentsBefore   :: [(Int, LEpaComment)]
+  { commentsBefore   :: [(Int, EpaCommentTok)]
   , importStatement  :: LImportDecl GhcPs
   , commentsSameline :: [(Int, EpaCommentTok)]
-  , commentsAfter    :: [(Int, LEpaComment)]
+  , commentsAfter    :: [(Int, EpaCommentTok)]
   }
 
 instance Show ImportStatementRecord where
@@ -266,13 +243,13 @@ transformToImportLine startPos is =
       :: [LEpaComment] -> ExactPrint.Pos -> FinalList ImportLine ExactPrint.Pos
     flattenComms = \case
       [] -> finalPure
-      lcomm@(L (Anchor span _) _) : commRest -> \lastSpanEnd -> do
+      (L (Anchor span _) (EpaComment comm _) : commRest) -> \lastSpanEnd -> do
         case ExactPrint.ss2delta lastSpanEnd span of
           SameLine i -> do
-            finalYield $ SamelineComment (i, lcomm)
+            finalYield $ SamelineComment (i, comm)
           DifferentLine l c -> do
             finalYield $ EmptyLines (l - 1)
-            finalYield $ NewlineComment (c - 1, lcomm)
+            finalYield $ NewlineComment (c - 1, comm)
         flattenComms commRest (ExactPrint.ss2posEnd span)
     flattenDecls
       :: [LImportDecl GhcPs]
@@ -281,41 +258,43 @@ 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
+          in
-                span1 <- flattenComms commsBefore lastSpanEnd
+            do
-                let newlines = case ExactPrint.ss2delta span1 declSpan of
+              span1 <- flattenComms commsBefore lastSpanEnd
-                      SameLine _        -> 0
+              let newlines = case ExactPrint.ss2delta span1 declSpan of
-                      DifferentLine i _ -> i - 1
+                    SameLine _        -> 0
-                finalYield $ EmptyLines newlines
+                    DifferentLine i _ -> i - 1
-                finalYield $ ImportStatement ImportStatementRecord
+              finalYield
-                  { commentsBefore   = []
+                $ EmptyLines newlines
-                  , importStatement  = L (SrcSpanAnn cleanEpAnn srcSpan) decl
+              finalYield $ ImportStatement ImportStatementRecord
-                  , commentsSameline = []
+                { commentsBefore   = []
-                  , commentsAfter    = []
+                , importStatement  = L (SrcSpanAnn cleanEpAnn srcSpan) decl
-                  }
+                , commentsSameline = []
-                span2 <- flattenComms commsAfter (ExactPrint.ss2posEnd declSpan)
+                , commentsAfter    = []
-                flattenDecls declRest span2
+                }
+              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, LEpaComment)]
+data Partial = PartialCommsOnly [(Int, EpaCommentTok)]
              | PartialImport ImportStatementRecord
 
 groupifyImportLines :: [ImportLine] -> [ImportLine]
 groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls
  where
   go acc [] = case acc of
-    PartialCommsOnly comms -> reverse comms `forM_` \comm ->
+    PartialCommsOnly comms ->
-      finalYield $ NewlineComment comm
+      reverse comms `forM_` \comm -> finalYield $ NewlineComment comm
     PartialImport partialRecord ->
       finalYield $ ImportStatement $ unpartial partialRecord
   go acc (line1 : lineR) = do
@@ -327,10 +306,9 @@ groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls
           pure $ PartialCommsOnly []
         SamelineComment comm -> do
           pure $ PartialCommsOnly (comm : comms)
-        NewlineComment  comm   -> pure $ PartialCommsOnly (comm : comms)
+        NewlineComment comm -> pure $ PartialCommsOnly (comm : comms)
-        ImportStatement record -> pure $ PartialImport $ record
+        ImportStatement record ->
-          { commentsBefore = comms
+          pure $ PartialImport $ record { commentsBefore = comms }
-          }
       PartialImport partialRecord -> case line1 of
         e@EmptyLines{} -> do
           finalYield $ ImportStatement $ unpartial partialRecord
@@ -339,8 +317,7 @@ groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls
         SamelineComment comm -> do
           if (null $ commentsAfter partialRecord)
             then pure $ PartialImport partialRecord
-              { commentsSameline = tokenOnly comm
+              { commentsSameline = comm : commentsSameline partialRecord
-                                   : commentsSameline partialRecord
               }
             else pure $ PartialImport partialRecord
               { commentsAfter = comm : commentsAfter partialRecord
@@ -356,8 +333,6 @@ 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)
@@ -370,7 +345,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
@@ -386,8 +361,8 @@ sortCommentedImports =
     Left  x -> [x]
     Right y -> ImportStatement <$> y
   sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord]
-  sortGroups = List.sortOn
+  sortGroups =
-    (moduleNameString . unLoc . ideclName . unLoc . importStatement)
+    List.sortOn (moduleNameString . unLoc . ideclName . unLoc . importStatement)
   groupify :: [ImportLine] -> [Either ImportLine [ImportStatementRecord]]
   groupify cs = go [] cs
    where

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

@@ -389,9 +389,6 @@ docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
 docSeq [] = docEmpty
 docSeq l = allocateNode . BDSeq =<< sequence l
 
-docSeqSep :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
-docSeqSep = docSeq . List.intersperse docSeparator
-
 docLines :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
 docLines l = allocateNode . BDLines =<< sequence l
 
@@ -723,10 +720,6 @@ instance DocFlushCommsPost (Maybe GHC.RealSrcSpan) (ToBriDocM BriDocNumbered) wh
       bd <- bdm
       pure (i1, BDFlushCommentsPost (GHC.realSrcSpanEnd loc) shouldMark bd)
 
-instance DocFlushCommsPost GHC.EpaLocation (ToBriDocM BriDocNumbered) where
-  docFlushCommsPost shouldMark epaLocation =
-    docFlushCommsPost shouldMark (Just $ GHC.epaLocationRealSrcSpan epaLocation)
-
 instance DocFlushCommsPost ann (ToBriDocM BriDocNumbered)
       => DocFlushCommsPost ann (ToBriDocM [BriDocNumbered]) where
   docFlushCommsPost shouldMark loc bdm = do

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

@@ -275,53 +275,21 @@ layoutBriDocM = \case
     layoutBriDocM bd
   BDFlushCommentsPrior loc bd -> do
     comms <- takeBefore loc
-    startCurY <- mGet <&> _lstate_curY
     printComments comms
     mModify (\s -> s + CommentCounter (length comms))
     mModify $ \s -> s
       { _lstate_markerForDelta = Nothing
-      , _lstate_plannedSpace =
+      , _lstate_plannedSpace = case _lstate_markerForDelta s of
-        case _lstate_markerForDelta s of
           Nothing -> _lstate_plannedSpace s
           Just m ->
             let p1 = (srcLocLine m, srcLocCol m)
                 p2 = (srcLocLine loc, srcLocCol loc)
-            in -- trace ("_lstate_plannedSpace = " ++ show (_lstate_plannedSpace s)
+            -- traceShow (m, ExactPrint.pos2delta p1 p2) $ pure ()
-               --   ++ ", _lstate_markerForDelta = " ++ show (_lstate_markerForDelta s)
+            in case ExactPrint.pos2delta p1 p2 of
-               --   ++ ", _lstate_curY = " ++ show (_lstate_curY s)
+              SameLine{} -> _lstate_plannedSpace s
-               --   ++ ", p1 = " ++ show p1
-               --   ++ ", p2 = " ++ show p2
-               --   ++ ", startCurY = " ++ show startCurY
-               --   -- ++ ", delta = " ++ show (ExactPrint.pos2delta p1 p2)
-               -- ) $
-              case ExactPrint.pos2delta p1 p2 of
-              SameLine iDelta -> case _lstate_plannedSpace s of
-                -- There is a delta after a marker. That should only happen
-                -- after a block-comment. And the marker-delta is SameLine,
-                -- so if layout doesn't force a newline we respect the marker
-                -- delta (i.e. respect whitespace immediately after a block
-                -- comment) or we just use the plan.
-                PlannedNone        -> PlannedSameline iDelta
-                PlannedSameline i  -> PlannedSameline (max (iDelta - 0) i)
-                p@PlannedNewline{} -> p
-                p@PlannedDelta{}   -> p
               DifferentLine n _ -> case _lstate_plannedSpace s of
-                -- Marker with DifferentLine delta means that we want to
+                PlannedNone       -> PlannedNone
-                -- reproduce the newlines that were present in the input.
+                PlannedSameline i -> PlannedDelta n (_lstate_curY s + i)
-                -- These will be emptylines in cases where it makes sense to
-                -- reproduce them, e.g. between statements in a do-block.
-                PlannedNone       -> PlannedDelta n startCurY
-                                     --             ^^^^^^^^^
-                                     --
-                                     -- after a block-comment, _lstate_curY
-                                     -- matches the end of the comment.
-                                     -- But to not break layout we need to
-                                     -- restore the original.
-                                     -- E.g. consider > let {-comm-}
-                                     --               >     x = 13
-                                     --
-                                     --             vvvvvvvvvvvvvvv
-                PlannedSameline i -> PlannedDelta n (startCurY + i)
                 PlannedNewline{}  -> PlannedNewline n
                 PlannedDelta _ i  -> PlannedDelta n i
       }

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

@@ -1,9 +1,9 @@
 {-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE DataKinds #-}
 
 module Language.Haskell.Brittany.Internal.StepOrchestrate
   ( processModule
-  ) where
+  )
+where
 
 import           Language.Haskell.Brittany.Internal.Prelude
 
@@ -15,8 +15,7 @@ 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)
+import           GHC                            ( EpaCommentTok
-                                                , EpaCommentTok
                                                   ( EpaBlockComment
                                                   , EpaEofComment
                                                   , EpaLineComment
@@ -37,7 +36,7 @@ import           Language.Haskell.Brittany.Internal.Config.Types
 import           Language.Haskell.Brittany.Internal.Config.Types.Instances2
                                                 ( )
 import           Language.Haskell.Brittany.Internal.S2_SplitModule
-                                                ( splitModuleStart )
+                                                ( splitModule )
 import           Language.Haskell.Brittany.Internal.S3_ToBriDocTools
 import           Language.Haskell.Brittany.Internal.S4_WriteBriDoc
                                                 ( ppBriDoc )
@@ -47,8 +46,7 @@ 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
+import           Language.Haskell.Brittany.Internal.ToBriDoc (layouters)
-                                                ( layouters )
 
 
 
@@ -60,26 +58,86 @@ processModule
   :: TraceFunc
   -> Config
   -> PerItemConfig
-  -> FinalList ModuleElement p
+  -> GHC.ParsedSource
   -> IO ([BrittanyError], TextL.Text)
-processModule traceFunc conf inlineConf moduleElems = do
+processModule traceFunc conf inlineConf parsedModule = do
-  let FinalList moduleElementsStream = moduleElems
+  let shouldReformatHead =
-      ((out, errs), debugStrings) =
+        conf & _conf_layout & _lconfig_reformatModulePreamble & confUnpack
-        runIdentity
+  let
-          $ MultiRWSS.runMultiRWSTNil
+    wrapNonDeclToBriDoc = MultiRWSS.withMultiReader conf
-          $ MultiRWSS.withMultiWriterAW
+      . MultiRWSS.withMultiState_ (CommentCounter 0)
-          $ MultiRWSS.withMultiWriterAW
+    FinalList moduleElementsStream = splitModule
-          $ MultiRWSS.withMultiWriterW
+      shouldReformatHead
-          $ MultiRWSS.withMultiReader traceFunc
+      parsedModule
-          $ moduleElementsStream
+      (fmap GHC.realSrcSpanStart $ obtainAnnPos (GHC.hsmodAnn $ GHC.unLoc parsedModule) GHC.AnnWhere)
-              (\modElem cont -> do
+    ((out, errs), debugStrings) =
-                processModuleElement modElem
+      runIdentity
-                cont
+        $ MultiRWSS.runMultiRWSTNil
-              )
+        $ MultiRWSS.withMultiWriterAW
-              (\x -> do
+        $ 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
+              pure x
-              )
+            )
     -- _tracer = 
     --   -- if Seq.null debugStrings
     --   -- then id
@@ -93,94 +151,13 @@ processModule traceFunc conf inlineConf moduleElems = do
   --       MEExactModuleHead{}  -> useTraceFunc traceFunc "MEExactModuleHead"
   --       MEPrettyModuleHead{} -> useTraceFunc traceFunc "MEPrettyModuleHead"
   --       MEImportDecl{}       -> useTraceFunc traceFunc "MEImportDecl"
-  --       MEDecl decl _ ->
+  --       MEDecl{}             -> useTraceFunc traceFunc "MEDecl"
-  --         useTraceFunc
+  --       MEComment{}          -> useTraceFunc traceFunc "MEComment"
-  --           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
 
 commentToDoc :: (Int, EpaCommentTok) -> ToBriDocM BriDocNumbered
 commentToDoc (indent, c) = case c of
@@ -220,13 +197,17 @@ processDefault x = do
     _    -> mTell $ Text.Builder.fromString $ List.dropWhileEnd ((==) '\n') str
 
 
-getDeclConfig :: Config -> PerItemConfig -> GHC.LHsDecl GhcPs -> Config
+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 ->
+  mBindingConfs =
-    Map.lookup n $ _icd_perBinding inlineConf
+    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
@@ -236,15 +217,16 @@ ppToplevelDecl decl immediateAfterComms = do
   exactprintOnly <- mAsk <&> \declConfig ->
     declConfig & _conf_roundtrip_exactprint_only & confUnpack
   bd <- fmap fst $ if exactprintOnly
-    then briDocMToPPM layouters $ docSeq
+    then briDocMToPPM layouters
-      (briDocByExactNoComment decl : map commentToDoc immediateAfterComms)
+      $ 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
+      (r, errorCount) <- briDocMToPPM layouters
-        (innerDoc : map commentToDoc immediateAfterComms)
+        $ docSeq (innerDoc : map commentToDoc immediateAfterComms)
       if errorCount == 0
         then pure (r, 0)
         else briDocMToPPM layouters $ briDocByExactNoComment decl

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

@@ -15,7 +15,7 @@ import Language.Haskell.Brittany.Internal.Components.BriDoc
 
 
 layoutDataDecl
-  :: Maybe (LTyClDecl GhcPs)
+  :: LTyClDecl GhcPs
   -> EpAnn [AddEpAnn]
   -> LIdP GhcPs
   -> LHsQTyVars GhcPs
@@ -35,7 +35,7 @@ layoutDataDecl ltycl declEpAnn name (HsQTvs _ bndrs) pats defn = case defn of
           then do
             nameStr <- lrdrNameToTextAnn name
             consNameStr <- lrdrNameToTextAnn consName
-            tyVars <- mapM shareDoc $ createBndrDoc bndrs
+            tyVarLine <- shareDoc $ createBndrDoc bndrs
             patDocs <- mapM shareDoc $ layoutHsTyPats pats
             -- headDoc     <- fmap return $ docSeq
             --   [ appSep $ docLitS "newtype")
@@ -43,252 +43,181 @@ layoutDataDecl ltycl declEpAnn name (HsQTvs _ bndrs) pats defn = case defn of
             --   , appSep tyVarLine
             --   ]
             rhsDoc <- return <$> createDetailsDoc consNameStr details
-            docHandleComms declEpAnn $ createDerivingPar mDerivs $ docAlt
+            docHandleComms declEpAnn $ createDerivingPar mDerivs $ docSeq
-              [ -- newtype Tagged s b = Tagged { unTagged :: b }
+              [ appSep $ docLitS "newtype"
-                docSeq
+              , appSep $ docLit nameStr
-                [ appSep $ docLitS "newtype"
+              , appSep tyVarLine
-                , appSep $ docLit nameStr
+              , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
-                , appSep (docSeqSep tyVars)
+              , docSeparator
-                , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
+              , docLitS "="
-                , docSeparator
+              , docSeparator
-                , docLitS "="
+              , docHandleComms epAnn $ rhsDoc
-                , docSeparator
-                , docForceParSpacing $ docHandleComms epAnn $ rhsDoc
-                ]
-              , -- newtype Tagged s b
-                --   = Tagged { unTagged :: b }
-                -- newtype Tagged s
-                --                b
-                --   = Tagged { unTagged :: b }
-                docAddBaseY BrIndentRegular $ docPar
-                  ( docSeq
-                    [ appSep $ docLitS "newtype"
-                    , appSep $ docLit nameStr
-                    , docAlt
-                      [ docForceSingleline $ docSeq
-                        [ appSep (docSeqSep tyVars)
-                        , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
-                        ]
-                      , docSetBaseY $ docLines
-                        $ map docForceSingleline $ tyVars ++ patDocs
-                      ]
-                    ]
-                  )
-                  ( docSeq
-                    [ docLitS "="
-                    , docSeparator
-                    , docHandleComms epAnn $ rhsDoc
-                    ]
-                  )
-              , -- newtype Tagged
-                --   s
-                --   b
-                --   = Tagged { unTagged :: b }
-                docAddBaseY BrIndentRegular $ docPar
-                  ( docSeq
-                    [ appSep $ docLitS "newtype"
-                    , appSep $ docLit nameStr
-                    -- , appSep tyVarLine
-                    -- , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
-                    ]
-                  )
-                  ( docLines
-                    $  map (docEnsureIndent BrIndentRegular) tyVars
-                    ++ map (docEnsureIndent BrIndentRegular) patDocs
-                    ++ [ docSeq
-                         [ docLitS "="
-                         , docSeparator
-                         , docHandleComms epAnn $ rhsDoc
-                         ]
-                       ]
-                  )
               ]
-          else maybe
+          else briDocByExactNoComment ltycl
-            (error
+      _ -> briDocByExactNoComment ltycl
-            $  "Unsupported form of DataFamInstDecl:"
-            ++ " ConDeclH98 with context"
-            )
-            briDocByExactNoComment
-            ltycl
-      _ -> maybe
-            (error
-            $  "Unsupported form of DataFamInstDecl:"
-            ++ " ConDeclH98 with forall"
-            )
-            briDocByExactNoComment
-            ltycl
-  HsDataDefn NoExtField NewType _ _ Just{} _ _ -> maybe
-    (error $ "Unsupported form of DataFamInstDecl: NewType _ _ Just _ _")
-    briDocByExactNoComment
-    ltycl
-  HsDataDefn NoExtField NewType _ _ Nothing _ _ -> maybe
-    (error $ "Unsupported form of DataFamInstDecl: NewType _ _ Nothing _ _")
-    briDocByExactNoComment
-    ltycl
 
-  -- data MyData = MyData ..
+
-  -- data MyData = MyData { .. }
+  -- data MyData a b
-  HsDataDefn NoExtField DataType ctxMay _ctype Nothing conss mDerivs -> do
+  -- (zero constructors)
+  HsDataDefn NoExtField DataType ctxMay _ctype Nothing [] mDerivs -> do
     lhsContextDoc <- case ctxMay of
       Just (L _ lhsContext) -> shareDoc $ createContextDoc lhsContext
       Nothing -> pure docEmpty
     nameStr <- lrdrNameToTextAnn name
-    tyVarLine <- shareDoc $ docSeqSep $ createBndrDoc bndrs
+    tyVarLine <- return <$> createBndrDoc bndrs
     patDocs <- mapM shareDoc $ layoutHsTyPats pats
-    lhsDoc <- shareDoc $ docSeq
+    docHandleComms declEpAnn $ createDerivingPar mDerivs $ docSeq
-      [ -- TOOD92 docNodeAnnKW ltycl (Just GHC.AnnData) $ 
+      [ appSep $ docLitS "data"
-        appSep $ docLitS "data"
+      , lhsContextDoc
-      , docForceSingleline $ lhsContextDoc
       , appSep $ docLit nameStr
       , appSep tyVarLine
       , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
       ]
-    let prefixes = "=" : repeat "|"
+
-    layoutConssResult <- mapM layoutConDecl (zip prefixes conss)
+  -- data MyData = MyData ..
-    case sequence layoutConssResult of
+  -- data MyData = MyData { .. }
-      Left err -> maybe (error err) briDocByExactNoComment ltycl
+  HsDataDefn NoExtField DataType ctxMay _ctype Nothing [cons] mDerivs ->
-      Right [] -> do
+    case cons of
-        docHandleComms declEpAnn $ createDerivingPar mDerivs $ docSeq
+      (L _ (ConDeclH98 epAnn consName _hasExt qvars mRhsContext details _conDoc))
-          [ appSep $ docLitS "data"
+        -> do
-          , lhsContextDoc
+          lhsContextDoc <- case ctxMay of
-          , appSep $ docLit nameStr
+            Just (L _ lhsContext) -> shareDoc $ createContextDoc lhsContext
-          , appSep tyVarLine
+            Nothing -> pure docEmpty
-          , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
+          nameStr <- lrdrNameToTextAnn name
-          ]
+          consNameStr <- lrdrNameToTextAnn consName
-      Right [(consDocSl, consDocMl)] -> do
+          tyVarLine <- return <$> createBndrDoc bndrs
-        docHandleComms declEpAnn $ createDerivingPar mDerivs $ docAlt
+          patDocs <- mapM shareDoc $ layoutHsTyPats pats
-          [ -- data D = forall a . Show a => D a
+          forallDocMay <- case createForallDoc qvars of
-            docSeq [lhsDoc, consDocSl]
+            Nothing -> pure Nothing
-          , -- data D
+            Just x -> Just . pure <$> x
-            --   = forall a . Show a => D a
+          rhsContextDocMay <- case mRhsContext of
-            -- data D
+            Nothing -> pure Nothing
-            --   = forall a
+            Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt
-            --   . Show a =>
+          rhsDoc <- return <$> createDetailsDoc consNameStr details
-            --     D a
+          let posEqual = obtainAnnPos epAnn AnnEqual
-            docAddBaseY BrIndentRegular
+          consDoc <-
-            $ docPar lhsDoc
+            shareDoc
-              (docNonBottomSpacing $ docAlt [consDocSl, consDocMl])
+            $ docHandleComms epAnn
-          , -- data
+            $ docHandleComms posEqual
-            --   Show a =>
+            $ docNonBottomSpacing
-            --   D
+            $ case (forallDocMay, rhsContextDocMay) of
-            --   = rhsDoc
+                (Just forallDoc, Just rhsContextDoc) -> docLines
-            -- This alternative is only for -XDatatypeContexts.
+                  [ docSeq
-            -- But I think it is rather unlikely this will trigger without
+                    [docLitS "=", docSeparator, docForceSingleline forallDoc]
-            -- -XDataTypeContexts, especially with the `docNonBottomSpacing`
+                  , docSeq
-            -- above, so while not strictly necessary, this should not
+                    [ docLitS "."
-            -- hurt.
+                    , docSeparator
-            docAddBaseY BrIndentRegular $ docPar
+                    , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc]
-            (-- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $
+                    ]
-             docLitS "data")
+                  ]
-            (docLines
+                (Just forallDoc, Nothing) -> docLines
-              [ lhsContextDoc
+                  [ docSeq
-              , docSeq
+                    [docLitS "=", docSeparator, docForceSingleline forallDoc]
-                [ appSep $ docLit nameStr
+                  , docSeq [docLitS ".", docSeparator, rhsDoc]
+                  ]
+                (Nothing, Just rhsContextDoc) -> docSeq
+                  [ docLitS "="
+                  , docSeparator
+                  , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc]
+                  ]
+                (Nothing, Nothing) ->
+                  docSeq [docLitS "=", docSeparator, rhsDoc]
+          docHandleComms declEpAnn $ createDerivingPar mDerivs $ docAlt
+            [ -- data D = forall a . Show a => D a
+              docSeq
+              [ -- TOOD92 docNodeAnnKW ltycl (Just GHC.AnnData) $ 
+                docSeq
+                [ appSep $ docLitS "data"
+                , docForceSingleline $ lhsContextDoc
+                , appSep $ docLit nameStr
+                , appSep tyVarLine
+                , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
+                ]
+              , docHandleComms epAnn $ docHandleComms posEqual $ docLitS "="
+              , docSeparator
+              , docSetIndentLevel $ docSeq
+                [ case forallDocMay of
+                  Nothing -> docEmpty
+                  Just forallDoc ->
+                    docSeq
+                      [ docForceSingleline forallDoc
+                      , docSeparator
+                      , docLitS "."
+                      , docSeparator
+                      ]
+                , maybe docEmpty docForceSingleline rhsContextDocMay
+                , rhsDoc
+                ]
+              ]
+            , -- data D
+              --   = forall a . Show a => D a
+              docAddBaseY BrIndentRegular $ docPar
+              ( -- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $ 
+                docSeq
+                [ appSep $ docLitS "data"
+                , docForceSingleline lhsContextDoc
+                , appSep $ docLit nameStr
                 , tyVarLine
                 , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
                 ]
-              , consDocMl
+              )
-              ]
+              (docSeq
-            )
+                [ docHandleComms epAnn $ docHandleComms posEqual $ docLitS "="
-          ]
+                , docSeparator
-      Right consDocTuples -> do
+                , docSetIndentLevel $ docSeq
-        docHandleComms declEpAnn
+                  [ case forallDocMay of
-          $ createDerivingPar mDerivs
+                    Nothing -> docEmpty
-          $ docAddBaseY BrIndentRegular
+                    Just forallDoc ->
-          $ docPar
+                      docSeq
-            (docAlt
+                        [ docForceSingleline forallDoc
-              [ -- data Show a => D a
+                        , docSeparator
-                lhsDoc
+                        , docLitS "."
-              , -- data
+                        , docSeparator
-                --   Show a =>
+                        ]
-                --   D
+                  , maybe docEmpty docForceSingleline rhsContextDocMay
-                -- This alternative is only for -XDatatypeContexts.
+                  , rhsDoc
-                -- But I think it is rather unlikely this will trigger without
-                -- -XDataTypeContexts, especially with the `docNonBottomSpacing`
-                -- above, so while not strictly necessary, this should not
-                -- hurt.
-                docAddBaseY BrIndentRegular $ docPar
-                (-- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $
-                 docLitS "data")
-                (docLines
-                  [ lhsContextDoc
-                  , docSeq
-                    [ appSep $ docLit nameStr
-                    , tyVarLine
-                    , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
-                    ]
                   ]
-                )
-              ]
-            )
-            (docLines $ [docAlt [sl, ml] | (sl, ml) <- consDocTuples])
-  
-  HsDataDefn NoExtField DataType _ _ Just{} _ _ -> maybe
-    (error $ "Unsupported form of DataFamInstDecl: DataType _ _ Just _ _")
-    briDocByExactNoComment
-    ltycl
-
-layoutConDecl
-  :: (String, LConDecl GhcPs)
-  -> ToBriDocM
-       (Either String (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered))
-layoutConDecl (prefix, L _ con) = case con of
-  ConDeclH98 epAnn consName _hasExt qvars mRhsContext details _conDoc -> do
-    consNameStr  <- lrdrNameToTextAnn consName
-    forallDocMay <- case createForallDoc qvars of
-      Nothing -> pure Nothing
-      Just x  -> Just . pure <$> x
-    rhsContextDocMay <- case mRhsContext of
-      Nothing         -> pure Nothing
-      Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt
-    detailsDoc <- shareDoc $ createDetailsDoc consNameStr details
-    let posEqual = obtainAnnPos epAnn AnnEqual
-    pure $ Right
-      ( docSeq
-          [ docHandleComms epAnn $ docHandleComms posEqual $ docLitS prefix
-          , docSeparator
-          , docSetIndentLevel $ docSeq
-            [ case forallDocMay of
-              Nothing        -> docEmpty
-              Just forallDoc -> docSeq
-                [ docForceSingleline forallDoc
-                , docSeparator
-                , docLitS "."
-                , docSeparator
                 ]
-            , maybe docEmpty docForceSingleline rhsContextDocMay
+              )
-            , detailsDoc
+            , -- data D
+              --   = forall a
+              --   . Show a =>
+              --     D a
+              docAddBaseY BrIndentRegular $ docPar
+              ( -- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $ 
+                docSeq
+                [ appSep $ docLitS "data"
+                , docForceSingleline lhsContextDoc
+                , appSep $ docLit nameStr
+                , tyVarLine
+                , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
+                ]
+              )
+              consDoc
+            , -- data
+              --   Show a =>
+              --   D
+              --   = forall a
+              --   . Show a =>
+              --     D a
+              -- This alternative is only for -XDatatypeContexts.
+              -- But I think it is rather unlikely this will trigger without
+              -- -XDataTypeContexts, especially with the `docNonBottomSpacing`
+              -- above, so while not strictly necessary, this should not
+              -- hurt.
+              docAddBaseY BrIndentRegular $ docPar
+              (docLitS "data")
+              (docLines
+                [ lhsContextDoc
+                , -- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $
+                  docSeq [appSep $ docLit nameStr, tyVarLine, docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]]
+                , consDoc
+                ]
+              )
             ]
-          ]
+      _ -> briDocByExactNoComment ltycl
-      , docHandleComms epAnn
-        $ docHandleComms posEqual
-        $ docNonBottomSpacing
-        $ case (forallDocMay, rhsContextDocMay) of
-            (Just forallDoc, Just rhsContextDoc) -> docLines
-              [ docSeq
-                [docLitS prefix, docSeparator, docForceSingleline forallDoc]
-              , docSeq
-                [ docLitS "."
-                , docSeparator
-                , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY detailsDoc]
-                ]
-              ]
-            (Just forallDoc, Nothing) -> docLines
-              [ docSeq
-                [docLitS prefix, docSeparator, docForceSingleline forallDoc]
-              , docSeq [docLitS ".", docSeparator, detailsDoc]
-              ]
-            (Nothing, Just rhsContextDoc) -> docSeq
-              [ docLitS prefix
-              , docSeparator
-              , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY detailsDoc]
-              ]
-            (Nothing, Nothing) -> docSeq
-              [docLitS prefix, docSeparator, detailsDoc]
-      )
-  ConDeclGADT{} -> pure
-    $ Left "Unsupported: ConDeclGADT inside DataFamInstDecl"
 
+  _ -> briDocByExactNoComment ltycl
 
 layoutHsTyPats
   :: [LHsTypeArg GhcPs] -> [ToBriDocM BriDocNumbered]
@@ -324,24 +253,25 @@ createContextDoc (t1 : tR) = do
       ]
     ]
 
-createBndrDoc :: [LHsTyVarBndr flag GhcPs] -> [ToBriDocM BriDocNumbered]
+createBndrDoc :: [LHsTyVarBndr flag GhcPs] -> ToBriDocM BriDocNumbered
-createBndrDoc = map $ \x -> do
+createBndrDoc bs = do
-  (vname, mKind) <- case x of
+  tyVarDocs <- bs `forM` \case
     (L _ (UserTyVar _ _ext vname)) -> return $ (lrdrNameToText vname, Nothing)
     (L _ (KindedTyVar _ _ext lrdrName kind)) -> do
       d <- shareDoc $ callLayouter layout_type kind
       return $ (lrdrNameToText lrdrName, Just $ d)
-  case mKind of
+  docSeq $ List.intersperse docSeparator $ tyVarDocs <&> \(vname, mKind) ->
-    Nothing -> docLit vname
+    case mKind of
-    Just kind -> docSeq
+      Nothing -> docLit vname
-      [ docLitS "("
+      Just kind -> docSeq
-      , docLit vname
+        [ docLitS "("
-      , docSeparator
+        , docLit vname
-      , docLitS "::"
+        , docSeparator
-      , docSeparator
+        , docLitS "::"
-      , kind
+        , docSeparator
-      , docLitS ")"
+        , kind
-      ]
+        , docLitS ")"
+        ]
 
 createDerivingPar
   :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
@@ -455,7 +385,8 @@ createDetailsDoc consNameStr details = case details of
     let ((fName1, fType1), fDocR) = case mkFieldDocs fields of
           (doc1:docR) -> (doc1, docR)
           _ -> error "cannot happen (TM)"
-    allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack
+    -- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack
+    let allowSingleline = False
     docAddBaseY BrIndentRegular $ runFilteredAlternative $ do
         -- single-line: { i :: Int, b :: Bool }
       addAlternativeCond allowSingleline $ docSeq
@@ -481,7 +412,7 @@ createDetailsDoc consNameStr details = case details of
         , docSeparator
         , docHandleComms posClose $ docLitS "}"
         ]
-      addAlternative $ docSetParSpacing $ docPar
+      addAlternative $ docPar
         (docLit consNameStr)
         (docNonBottomSpacingS $ docLines
           [ docAlt
@@ -537,7 +468,7 @@ createForallDoc
   :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered)
 createForallDoc [] = Nothing
 createForallDoc lhsTyVarBndrs =
-  Just $ docSeq [docLitS "forall ", docSeqSep $ createBndrDoc lhsTyVarBndrs]
+  Just $ docSeq [docLitS "forall ", createBndrDoc lhsTyVarBndrs]
 
 createNamesAndTypeDoc
   :: LConDeclField GhcPs

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

@@ -238,10 +238,7 @@ layoutGrhs (L _ (GRHS epAnn guards body)) = do
   guardDocs <- case guards of
     [] -> pure []
     _  -> docFlushCommsPost False posArrow $ callLayouter layout_stmt `mapM` guards
-  let bodyEndPos = case locA $ getLoc body of
+  bodyDoc <- callLayouter layout_expr body
-        GHC.RealSrcSpan s _ -> Just s
-        GHC.UnhelpfulSpan{} -> Nothing
-  bodyDoc <- docFlushCommsPost True bodyEndPos $ callLayouter layout_expr body
   return (Just epAnn, guardDocs, bodyDoc)
 
 layoutPatternBind
@@ -263,7 +260,7 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do
       let t' = fixPatternBindIdentifier match t
       docLit t'
     _ -> pure Nothing
-  patDoc <- case (mIdDoc, patDocs) of
+  patDoc <- docHandleComms lmatch $ case (mIdDoc, patDocs) of -- TODO92 we use lmatch twice here!
     (Just idDoc, p1 : p2 : pr) | isInfix -> if null pr
       then docCols
         ColPatternsFuncInfix
@@ -808,7 +805,7 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of
                        typeDoc
   DataDecl epAnn name tyVars _ dataDefn -> do
     layouters <- mAsk
-    layout_dataDecl layouters (Just ltycl) epAnn name tyVars [] dataDefn
+    layout_dataDecl layouters ltycl epAnn name tyVars [] dataDefn
   _ -> briDocByExactNoComment ltycl
 
 layoutTyVarBndr :: Bool -> ToBriDoc (HsTyVarBndr ())
@@ -976,7 +973,7 @@ layoutClsInst (L declLoc _) cid = do
         layouters <- mAsk
         layout_dataDecl
           layouters
-          Nothing
+          (error "Unsupported form of DataFamInstDecl")
           epAnn
           tycon
           (case bndrs of

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

@@ -556,10 +556,7 @@ layoutExpr lexpr@(L _ expr) = do
       -- to making brittany idempotent, even though the result is non-optimal
       -- if "let" is moved horizontally as part of the transformation, as the
       -- comments before the first let item are moved horizontally with it.
-      letDoc  <- shareDoc
+      letDoc  <- shareDoc $ wrapLet $ docLit $ Text.pack "let"
-        $ docFlushCommsPost True spanLet
-        $ wrapLet
-        $ docLitS "let"
       inDoc   <- shareDoc $ wrapIn $ docLit $ Text.pack "in"
       docSetBaseAndIndent $ case fmap snd mBindDocs of
         Just [bindDoc] -> runFilteredAlternative $ do

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

@@ -198,9 +198,6 @@ layoutOpTree allowSinglelinePar = \case
           pure (pure op, subDoc)
     sharedOpsFlat <- flattenList docOps
     sharedOps     <- simpleTransform docOps
-    let lastWrap = if getPrec fixity <= 1
-          then docForceParSpacing
-          else docForceSingleline
     coreAlternative hasParen
                     locO
                     locC
@@ -208,12 +205,11 @@ layoutOpTree allowSinglelinePar = \case
                     docL
                     sharedOps
                     sharedOpsFlat
-                    lastWrap
+                    docForceParSpacing
   OpLeaf l -> pure l
  where
-  isPrec0 x = getPrec x == 0
+  isPrec0 = \case
-  getPrec = \case
+    Fixity _ prec _ -> prec == 0
-    Fixity _ prec _ -> prec
   coreAlternative
     :: Bool
     -> Maybe GHC.RealSrcLoc
@@ -227,10 +223,7 @@ layoutOpTree allowSinglelinePar = \case
   coreAlternative hasParen locO locC fixity docL sharedOps sharedOpsFlat lastWrap
     = do
       indentPolicy <- askLayoutConf _lconfig_indentPolicy
-      let zeroOps = null sharedOps
+      let wrapParenIfSl x inner = if x then wrapParenSl inner else docSetParSpacing inner
-          wrapParenIfSl x inner = if x
-            then wrapParenSl inner
-            else docSetParSpacing inner
           wrapParenSl inner = docAlt
             [ docSeq
               [ docLit $ Text.pack "("
@@ -248,7 +241,7 @@ layoutOpTree allowSinglelinePar = \case
           wrapParenMl innerHead innerLines = docSetBaseY $ docLines
             (  [ docCols
                    ColOpPrefix
-                   [ (if zeroOps then id else appSep) $ docLit $ Text.pack "("
+                   [ appSep $ docLit $ Text.pack "("
                    , docHandleComms locO $ innerHead
                    ]
                ]
@@ -272,35 +265,33 @@ layoutOpTree allowSinglelinePar = \case
           $ wrapParenIfSl hasParen
           $ docSetParSpacing
           $ docSeq
-              ([docForceSingleline docL] ++ case splitFirstLast sharedOpsFlat of
+          ([docForceSingleline docL] ++ case splitFirstLast sharedOpsFlat of
-                FirstLastEmpty -> []
+            FirstLastEmpty -> []
-                FirstLastSingleton (od, ed) ->
+            FirstLastSingleton (od, ed) ->
-                  [ docSeparator
+              [docSeparator, docForceSingleline od, docSeparator, lastWrap ed]
-                  , docForceSingleline od
+            FirstLast (od1, ed1) ems (odN, edN) ->
-                  , docSeparator
+              (  [ docSeparator
-                  , lastWrap ed
+                 , docForceSingleline od1
-                  ]
+                 , docSeparator
-                FirstLast (od1, ed1) ems (odN, edN) ->
+                 , docForceSingleline ed1
-                  (  [ docSeparator
+                 ]
-                     , docForceSingleline od1
+              ++ join
+                   [ [ docSeparator
+                     , docForceSingleline od
                      , docSeparator
-                     , docForceSingleline ed1
+                     , docForceSingleline ed
                      ]
-                  ++ join
+                   | (od, ed) <- ems
-                       [ [ docSeparator
+                   ]
-                         , docForceSingleline od
+              ++ [ docSeparator
-                         , docSeparator
+                 , docForceSingleline odN
-                         , docForceSingleline ed
+                 , docSeparator
-                         ]
+                 , lastWrap edN
-                       | (od, ed) <- ems
+                 ]
-                       ]
-                  ++ [ docSeparator
-                     , docForceSingleline odN
-                     , docSeparator
-                     , lastWrap edN
-                     ]
-                  )
               )
+          )
+        -- this case rather leads to some unfortunate layouting than to anything
+        -- useful; disabling for now. (it interfers with cols stuff.)
         -- one
         -- + two
         -- + three
@@ -314,14 +305,15 @@ layoutOpTree allowSinglelinePar = \case
               IndentPolicyMultiple -> docForceSingleline
               IndentPolicyFree     -> id
         let curIsPrec0 = case fixity of
-              Nothing                -> False
+              Nothing -> False
               Just (Fixity _ prec _) -> prec == 0
         case sharedOps of
           [(od, ed)] | curIsPrec0 ->
             addAlternativeCond (not hasParen && isSingleOp)
               $ docSetParSpacing
-              $ docPar (docHandleComms locO $ docForceSingleline $ docL)
+              $ docPar
-                       (docSeq [od, docSeparator, singlelineUnlessFree ed])
+                (docHandleComms locO $ docForceSingleline $ docL)
+                (docSeq [od, docSeparator, singlelineUnlessFree ed])
           _ -> pure ()
         -- > ( one
         -- > + two
@@ -339,9 +331,9 @@ layoutOpTree allowSinglelinePar = \case
         -- >   + three
         addAlternative
           $ wrapParenMlIf
-            hasParen
+              hasParen
           -- ((if not hasParen then docAddBaseY BrIndentRegular else id) docL)
-            (if hasParen then docSetBaseY docL else docL)
+              (if hasParen then docSetBaseY docL else docL)
-            ((if hasParen then sharedOps else sharedOpsFlat) <&> \(od, ed) ->
+              ((if hasParen then sharedOps else sharedOpsFlat) <&> \(od, ed) ->
-              docCols ColOpPrefix [appSep od, docSetBaseY ed]
+                docCols ColOpPrefix [appSep od, docSetBaseY ed]
-            )
+              )

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

@@ -47,20 +47,18 @@ layoutStmt lstmt@(L _ stmt) = do
           ]
         ]
     LetStmt epAnn binds -> docHandleComms epAnn $ do
-      let spanLet = obtainAnnPos epAnn AnnLet
-      letDoc <- shareDoc $ docFlushCommsPost True spanLet $ docLitS "let"
       let isFree = indentPolicy == IndentPolicyFree
       let indentFourPlus = indentAmount >= 4
       (wrapBinds, bindrDocsMay) <- callLayouter layout_localBinds binds
       case bindrDocsMay of
-        Nothing -> letDoc
+        Nothing -> docLit $ Text.pack "let"
           -- i just tested the above, and it is indeed allowed. heh.
-        Just (_, []) -> letDoc -- this probably never happens
+        Just (_, []) -> docLit $ Text.pack "let" -- this probably never happens
         Just (_, [bindDoc]) -> docAlt
           [ -- let bind = expr
             docCols
             ColDoLet
-            [ appSep $ letDoc
+            [ appSep $ docLit $ Text.pack "let"
             , let
                 f = case indentPolicy of
                   IndentPolicyFree -> docSetBaseAndIndent
@@ -73,7 +71,7 @@ layoutStmt lstmt@(L _ stmt) = do
           , -- let
             --   bind = expr
             docAddBaseY BrIndentRegular $ docPar
-            letDoc
+            (docLit $ Text.pack "let")
             (wrapBinds $ docSetBaseAndIndent $ return bindDoc)
           ]
         Just (_, bindDocs) -> runFilteredAlternative $ do
@@ -81,7 +79,7 @@ layoutStmt lstmt@(L _ stmt) = do
           --     bbb = exprb
           --     ccc = exprc
           addAlternativeCond (isFree || indentFourPlus) $ docSeq
-            [ appSep $ letDoc
+            [ appSep $ docLit $ Text.pack "let"
             , let
                 f = if indentFourPlus
                   then docEnsureIndent BrIndentRegular
@@ -95,7 +93,7 @@ layoutStmt lstmt@(L _ stmt) = do
           addAlternativeCond (not indentFourPlus)
             $ docAddBaseY BrIndentRegular
             $ docPar
-                letDoc
+                (docLit $ Text.pack "let")
                 (wrapBinds $ docSetBaseAndIndent $ docLines $ return <$> bindDocs)
     RecStmt epAnn (L _ stmts) _ _ _ _ _ ->
       docHandleComms epAnn $ runFilteredAlternative $ do

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

@@ -370,9 +370,7 @@ layoutType ltype@(L _ typ) = docHandleComms ltype $ case typ of
             ]
           )
       ]
-  HsBangTy epAnn (HsSrcBang NoSourceText NoSrcUnpack SrcStrict) innerTy -> do
+  HsBangTy{} -> -- TODO
-    docHandleComms epAnn $ docSeq [docLitS "!", layoutType innerTy]
-  HsBangTy {} ->
     briDocByExactInlineOnly "HsBangTy{}" ltype
   -- HsBangTy bang typ1 -> do
   --   let bangStr = case bang of

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

@@ -24,7 +24,6 @@ import           GHC                            ( Anno
                                                 , ParsedSource
                                                 , XRec
                                                 , LImportDecl
-                                                , LEpaComment
                                                 )
 import GHC.Utils.Outputable(Outputable)
 import Language.Haskell.Brittany.Internal.Config.Types
@@ -53,7 +52,7 @@ data BrittanyError
   | forall ast . (Data.Data.Data (XRec GhcPs ast), Outputable (Anno ast)) => ErrorUnknownNode String (XRec GhcPs ast)
     -- ^ internal error: pretty-printing is not implemented for type of node
     --   in the syntax-tree
-  | ErrorOutputCheck String
+  | ErrorOutputCheck
     -- ^ checking the output for syntactic validity failed
 
 
@@ -90,8 +89,6 @@ 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
@@ -122,7 +119,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, LEpaComment)
+  | MEComment (Int, EpaCommentTok)
     -- ^ 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.
@@ -239,7 +236,7 @@ data Layouters = Layouters
              )
          )
   , layout_dataDecl
-    :: Maybe (GHC.LTyClDecl GhcPs)
+    :: GHC.LTyClDecl GhcPs
     -> GHC.EpAnn [GHC.AddEpAnn]
     -> GHC.LIdP GhcPs
     -> GHC.LHsQTyVars GhcPs

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

@@ -152,7 +152,7 @@ layoutWriteComment absolute isBlock dp commentLines s = do -- TODO92 we don't mo
   mSet state
     { _lstate_plannedSpace    = if isBlock
       then case _lstate_plannedSpace state of
-        p@PlannedNone       -> p
+        PlannedNone         -> PlannedSameline 1
         p@PlannedSameline{} -> p
         PlannedNewline l ->
           if l <= y then PlannedSameline 1 else PlannedNewline (l - y)

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

@@ -381,15 +381,9 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
         putErrorLn left
         ExceptT.throwE 60
       Right (parsedSource, hasCPP) -> do
-        let moduleElementList = splitModuleDecls parsedSource
         (inlineConf, perItemConf) <- do
           resE <-
-            liftIO
+            liftIO $ ExceptT.runExceptT $ extractCommentConfigs putErrorLnIO parsedSource
-              $ ExceptT.runExceptT
-              $ extractCommentConfigs
-                putErrorLnIO
-                (extractDeclMap parsedSource)
-                moduleElementList
           case resE of
             Left (err, input) -> do
               putErrorLn $ "Error: parse error in inline configuration:"
@@ -420,9 +414,9 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
                     .> _econf_omit_output_valid_check
                     .> confUnpack
               (ews, outRaw) <- if hasCPP || omitCheck
-                then liftIO $ processModule (TraceFunc putErrorLnIO) moduleConf perItemConf moduleElementList
+                then liftIO $ processModule (TraceFunc putErrorLnIO) moduleConf perItemConf parsedSource
                 else liftIO
-                  $ pPrintModuleAndCheck (TraceFunc putErrorLnIO) moduleConf perItemConf moduleElementList
+                  $ pPrintModuleAndCheck (TraceFunc putErrorLnIO) moduleConf perItemConf parsedSource
               let
                 hackF s = fromMaybe s $ TextL.stripPrefix
                   (TextL.pack "-- BRITANY_INCLUDE_HACK ")

source/test-suite/Main.hs

@@ -15,7 +15,6 @@ import Language.Haskell.Brittany.Internal
 import Language.Haskell.Brittany.Internal.Config.Config
 import Language.Haskell.Brittany.Internal.Config.Types
 import Language.Haskell.Brittany.Internal.Prelude
-import Test.HUnit (assertEqual)
 import qualified System.Directory
 import System.FilePath ((</>))
 import System.Timeout (timeout)
@@ -23,7 +22,6 @@ import Test.Hspec
 import qualified Text.Parsec as Parsec
 import Text.Parsec.Text (Parser)
 import qualified Data.List.Extra
-import qualified System.Console.ANSI as ANSI
 
 hush :: Either a b -> Maybe b
 hush = either (const Nothing) Just
@@ -284,15 +282,9 @@ roundTripEqual c t =
     `shouldReturn` Right (PPTextWrapper t)
 
 goldenTest :: Config -> Text -> Text -> Expectation
-goldenTest c input expected = do
+goldenTest c input expected =
-  result <- parsePrintModuleTests c "TestFakeFileName.hs" input
+  fmap (fmap PPTextWrapper) (parsePrintModuleTests c "TestFakeFileName.hs" input)
-  assertEqual
+    `shouldReturn` Right (PPTextWrapper expected)
-    (  ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Red]
-    ++ "golden input: see test source!"
-    ++ ANSI.setSGRCode [ANSI.Reset]
-    )
-    (Right (PPTextWrapper expected))
-    (fmap PPTextWrapper result)
 
 newtype PPTextWrapper = PPTextWrapper Text
   deriving Eq
@@ -323,7 +315,7 @@ defaultTestConfig = Config
     , _lconfig_allowSingleLineExportList       = coerce True
     , _lconfig_allowHangingQuasiQuotes         = coerce True
     , _lconfig_experimentalSemicolonNewlines   = coerce False
-    , _lconfig_allowSinglelineRecord           = coerce False
+    -- , _lconfig_allowSinglelineRecord     = coerce False
     , _lconfig_fixityAwareOps                  = coerce True
     , _lconfig_fixityAwareTypeOps              = coerce True
     , _lconfig_fixityBasedAddAlignParens       = coerce False