Refactor+Rewrite+Adaptation for ghc-9.2 support

brittany.cabal

@@ -38,9 +38,9 @@ flag pedantic
 common library
   build-depends:
     , aeson ^>= 2.0.1
-    , base ^>= 4.15.0
+    , base >= 4.15.0 && < 4.17
     , butcher ^>= 2.0.0
-    , bytestring ^>= 0.10.12
+    , bytestring >= 0.10.12 && < 0.12
     , cmdargs ^>= 0.10.21
     , containers ^>= 0.6.4
     , czipwith ^>= 1.0.1
@@ -49,17 +49,17 @@ common library
     , directory ^>= 1.3.6
     , extra ^>= 1.7.10
     , filepath ^>= 1.4.2
-    , ghc ^>= 9.0.1
+    , ghc >= 9.0.1 && < 9.3
-    , ghc-boot ^>= 9.0.1
+    , ghc-boot >= 9.0.1 && < 9.3
-    , ghc-boot-th ^>= 9.0.1
+    , ghc-boot-th >= 9.0.1 && < 9.3
-    , ghc-exactprint ^>= 0.6.4
+    , ghc-exactprint >= 0.6.4 && < 1.6
     , monad-memo ^>= 0.5.3
     , mtl ^>= 2.2.2
     , multistate ^>= 0.8.0
     , pretty ^>= 1.1.3
     , random ^>= 1.2.1
     , safe ^>= 0.3.19
-    , semigroups ^>= 0.19.2
+    , semigroups >= 0.19.2 && < 0.21
     , strict ^>= 0.4.0
     , syb ^>= 0.7.2
     , text ^>= 1.2.5
@@ -86,6 +86,21 @@ common library
   if flag(pedantic)
     ghc-options: -Werror
 
+  default-extensions: {
+    FlexibleContexts
+    FlexibleInstances
+    ScopedTypeVariables
+    MonadComprehensions
+    LambdaCase
+    MultiWayIf
+    KindSignatures
+    MultiParamTypeClasses
+    TypeApplications
+    RankNTypes
+    GADTs
+    BangPatterns
+  }
+
 common executable
   import: library
 
@@ -103,36 +118,42 @@ library
   autogen-modules: Paths_brittany
   hs-source-dirs: source/library
   exposed-modules:
+    Language.Haskell.Brittany.Main
     Language.Haskell.Brittany
     Language.Haskell.Brittany.Internal
-    Language.Haskell.Brittany.Internal.Backend
+    Language.Haskell.Brittany.Internal.Config.Config
-    Language.Haskell.Brittany.Internal.BackendUtils
+    Language.Haskell.Brittany.Internal.Config.InlineParsing
-    Language.Haskell.Brittany.Internal.Config
     Language.Haskell.Brittany.Internal.Config.Types
-    Language.Haskell.Brittany.Internal.Config.Types.Instances
+    Language.Haskell.Brittany.Internal.Config.Types.Instances1
-    Language.Haskell.Brittany.Internal.ExactPrintUtils
+    Language.Haskell.Brittany.Internal.Config.Types.Instances2
-    Language.Haskell.Brittany.Internal.LayouterBasics
+    Language.Haskell.Brittany.Internal.ToBriDoc.DataDecl
-    Language.Haskell.Brittany.Internal.Layouters.DataDecl
+    Language.Haskell.Brittany.Internal.ToBriDoc.Decl
-    Language.Haskell.Brittany.Internal.Layouters.Decl
+    Language.Haskell.Brittany.Internal.ToBriDoc.Expr
-    Language.Haskell.Brittany.Internal.Layouters.Expr
+    Language.Haskell.Brittany.Internal.ToBriDoc.IE
-    Language.Haskell.Brittany.Internal.Layouters.IE
+    Language.Haskell.Brittany.Internal.ToBriDoc.Import
-    Language.Haskell.Brittany.Internal.Layouters.Import
+    Language.Haskell.Brittany.Internal.ToBriDoc.Module
-    Language.Haskell.Brittany.Internal.Layouters.Module
+    Language.Haskell.Brittany.Internal.ToBriDoc.Pattern
-    Language.Haskell.Brittany.Internal.Layouters.Pattern
+    Language.Haskell.Brittany.Internal.ToBriDoc.Stmt
-    Language.Haskell.Brittany.Internal.Layouters.Stmt
+    Language.Haskell.Brittany.Internal.ToBriDoc.Type
-    Language.Haskell.Brittany.Internal.Layouters.Type
+    Language.Haskell.Brittany.Internal.Components.BriDoc
-    Language.Haskell.Brittany.Internal.Obfuscation
+    Language.Haskell.Brittany.Internal.Components.Obfuscation
-    Language.Haskell.Brittany.Internal.ParseModule
+    Language.Haskell.Brittany.Internal.S1_Parsing
+    Language.Haskell.Brittany.Internal.S2_SplitModule
+    Language.Haskell.Brittany.Internal.S3_ToBriDocTools
+    Language.Haskell.Brittany.Internal.S4_WriteBriDoc
+    Language.Haskell.Brittany.Internal.StepOrchestrate
     Language.Haskell.Brittany.Internal.Prelude
-    Language.Haskell.Brittany.Internal.PreludeUtils
+    Language.Haskell.Brittany.Internal.Transformations.T1_Alt
-    Language.Haskell.Brittany.Internal.Transformations.Alt
+    Language.Haskell.Brittany.Internal.Transformations.T2_Floating
-    Language.Haskell.Brittany.Internal.Transformations.Columns
+    Language.Haskell.Brittany.Internal.Transformations.T3_Par
-    Language.Haskell.Brittany.Internal.Transformations.Floating
+    Language.Haskell.Brittany.Internal.Transformations.T4_Columns
-    Language.Haskell.Brittany.Internal.Transformations.Indent
+    Language.Haskell.Brittany.Internal.Transformations.T5_Indent
-    Language.Haskell.Brittany.Internal.Transformations.Par
+    Language.Haskell.Brittany.Internal.WriteBriDoc.AlignmentAlgo
+    Language.Haskell.Brittany.Internal.WriteBriDoc.Operators
+    Language.Haskell.Brittany.Internal.WriteBriDoc.Types
     Language.Haskell.Brittany.Internal.Types
     Language.Haskell.Brittany.Internal.Utils
-    Language.Haskell.Brittany.Main
+    Language.Haskell.Brittany.Internal.Util.AST
     Paths_brittany
 
 executable brittany
@@ -145,7 +166,7 @@ test-suite brittany-test-suite
   import: executable
 
   build-depends:
-    , hspec ^>= 2.8.3
+    , hspec >= 2.8.3 && < 2.10
     , parsec ^>= 3.1.14
     , these ^>= 1.1
   hs-source-dirs: source/test-suite

data/15-regressions.blt

@@ -116,7 +116,7 @@ func = do
   let (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs'
       (bproblems, x) = resolveBuildTargets primaryPkg otherPkgs utargets''
       -- default local dir target if there's no given target
-      utargets'' = "foo"
+      utargets''     = "foo"
   return ()
 
 #test list comprehension comment placement
@@ -872,3 +872,21 @@ func =
   do
     y
   >>= x
+
+#test nested-arrow-type
+#pending
+fieldWith
+  :: a
+  -> a
+  -> (  ( GHC.RealSrcLoc
+        , a
+        , Either
+            (Maybe GHC.RealSrcLoc, ToBriDocM BriDocNumbered)
+            ( Maybe GHC.RealSrcLoc
+            , ToBriDocM BriDocNumbered
+            , ToBriDocM BriDocNumbered
+            )
+        )
+     -> ToBriDocM BriDocNumbered
+     )
+  -> [ToBriDocM BriDocNumbered]

source/library/Language/Haskell/Brittany.hs

@@ -1,9 +1,9 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 
 module Language.Haskell.Brittany
-  ( parsePrintModule
+  -- ( parsePrintModule
-  , staticDefaultConfig
+  -- , staticDefaultConfig
-  , forwardOptionsSyntaxExtsEnabled
+  ( forwardOptionsSyntaxExtsEnabled
   , userConfigPath
   , findLocalConfigPath
   , readConfigs
@@ -18,7 +18,6 @@ module Language.Haskell.Brittany
   , BrittanyError(..)
   ) where
 
-import Language.Haskell.Brittany.Internal
+import Language.Haskell.Brittany.Internal.Config.Config
-import Language.Haskell.Brittany.Internal.Config
 import Language.Haskell.Brittany.Internal.Config.Types
 import Language.Haskell.Brittany.Internal.Types

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

@@ -1,232 +1,42 @@
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 
 module Language.Haskell.Brittany.Internal
-  ( parsePrintModule
+  ( Parsing.parseModule
+  , Parsing.parseModuleFromString
+  , parsePrintModule
   , parsePrintModuleTests
-  , pPrintModule
+  , processModule
   , pPrintModuleAndCheck
    -- re-export from utils:
-  , parseModule
-  , parseModuleFromString
   , extractCommentConfigs
-  , getTopLevelDeclNameMap
+  , TraceFunc(TraceFunc)
-  ) where
+  )
+where
 
-import Control.Monad.Trans.Except
+import           Control.Monad.Trans.Except
-import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
+import           Data.CZipWith
-import qualified Data.ByteString.Char8
+import qualified Data.Text                     as Text
-import Data.CZipWith
+import qualified Data.Text.Lazy                as TextL
-import Data.Char (isSpace)
+import qualified GHC                     hiding ( parseModule )
-import Data.HList.HList
+import qualified GHC.Driver.Session            as GHC
-import qualified Data.Map as Map
+import           GHC.Hs
-import qualified Data.Maybe
+import qualified GHC.LanguageExtensions.Type   as GHC
-import qualified Data.Semigroup as Semigroup
+import qualified GHC.OldList                   as List
-import qualified Data.Sequence as Seq
+import           Language.Haskell.Brittany.Internal.Config.Config
-import qualified Data.Text as Text
+import           Language.Haskell.Brittany.Internal.Config.InlineParsing
-import qualified Data.Text.Lazy as TextL
+import           Language.Haskell.Brittany.Internal.Config.Types
-import qualified Data.Text.Lazy.Builder as Text.Builder
+import           Language.Haskell.Brittany.Internal.S3_ToBriDocTools
-import qualified Data.Yaml
+import           Language.Haskell.Brittany.Internal.Prelude
-import qualified GHC hiding (parseModule)
+import qualified Language.Haskell.Brittany.Internal.S1_Parsing
-import GHC (GenLocated(L))
+                                               as Parsing
-import qualified GHC.Driver.Session as GHC
+import           Language.Haskell.Brittany.Internal.StepOrchestrate
-import GHC.Hs
+                                                ( processModule )
-import qualified GHC.LanguageExtensions.Type as GHC
+import           Language.Haskell.Brittany.Internal.Types
-import qualified GHC.OldList as List
+import           Language.Haskell.Brittany.Internal.Utils
-import GHC.Parser.Annotation (AnnKeywordId(..))
+import Language.Haskell.Brittany.Internal.Config.Types.Instances1 ()
-import GHC.Types.SrcLoc (SrcSpan)
-import Language.Haskell.Brittany.Internal.Backend
-import Language.Haskell.Brittany.Internal.BackendUtils
-import Language.Haskell.Brittany.Internal.Config
-import Language.Haskell.Brittany.Internal.Config.Types
-import Language.Haskell.Brittany.Internal.ExactPrintUtils
-import Language.Haskell.Brittany.Internal.LayouterBasics
-import Language.Haskell.Brittany.Internal.Layouters.Decl
-import Language.Haskell.Brittany.Internal.Layouters.Module
-import Language.Haskell.Brittany.Internal.Prelude
-import Language.Haskell.Brittany.Internal.PreludeUtils
-import Language.Haskell.Brittany.Internal.Transformations.Alt
-import Language.Haskell.Brittany.Internal.Transformations.Columns
-import Language.Haskell.Brittany.Internal.Transformations.Floating
-import Language.Haskell.Brittany.Internal.Transformations.Indent
-import Language.Haskell.Brittany.Internal.Transformations.Par
-import Language.Haskell.Brittany.Internal.Types
-import Language.Haskell.Brittany.Internal.Utils
-import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
-import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
-import qualified UI.Butcher.Monadic as Butcher
 
 
 
-data InlineConfigTarget
-    = InlineConfigTargetModule
-    | InlineConfigTargetNextDecl    -- really only next in module
-    | InlineConfigTargetNextBinding -- by name
-    | InlineConfigTargetBinding String
-
-extractCommentConfigs
-  :: ExactPrint.Anns
-  -> TopLevelDeclNameMap
-  -> Either (String, String) (CConfig Maybe, PerItemConfig)
-extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
-  let
-    commentLiness =
-      [ ( k
-        , [ x
-          | (ExactPrint.Comment x _ _, _) <-
-            (ExactPrint.annPriorComments ann
-            ++ ExactPrint.annFollowingComments ann
-            )
-          ]
-        ++ [ x
-           | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <-
-             ExactPrint.annsDP ann
-           ]
-        )
-      | (k, ann) <- Map.toList anns
-      ]
-  let
-    configLiness = commentLiness <&> second
-      (Data.Maybe.mapMaybe $ \line -> do
-        l1 <-
-          List.stripPrefix "-- BRITTANY" line
-          <|> List.stripPrefix "--BRITTANY" line
-          <|> List.stripPrefix "-- brittany" line
-          <|> List.stripPrefix "--brittany" line
-          <|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}")
-        let l2 = dropWhile isSpace l1
-        guard
-          (("@" `isPrefixOf` l2)
-          || ("-disable" `isPrefixOf` l2)
-          || ("-next" `isPrefixOf` l2)
-          || ("{" `isPrefixOf` l2)
-          || ("--" `isPrefixOf` l2)
-          )
-        pure l2
-      )
-  let
-    configParser = Butcher.addAlternatives
-      [ ( "commandline-config"
-        , \s -> "-" `isPrefixOf` dropWhile (== ' ') s
-        , cmdlineConfigParser
-        )
-      , ( "yaml-config-document"
-        , \s -> "{" `isPrefixOf` dropWhile (== ' ') s
-        , Butcher.addCmdPart (Butcher.varPartDesc "yaml-config-document")
-        $ either
-            (\_ -> Butcher.Failure Nothing)
-            (\lconf -> Butcher.Success (mempty { _conf_layout = lconf }) "")
-        . Data.Yaml.decodeEither'
-        . Data.ByteString.Char8.pack
-          -- TODO: use some proper utf8 encoder instead?
-        )
-      ]
-    parser = do -- we will (mis?)use butcher here to parse the inline config
-                -- line.
-      let
-        nextDecl = do
-          conf <- configParser
-          Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf)
-      Butcher.addCmd "-next-declaration" nextDecl
-      Butcher.addCmd "-Next-Declaration" nextDecl
-      Butcher.addCmd "-NEXT-DECLARATION" nextDecl
-      let
-        nextBinding = do
-          conf <- configParser
-          Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf)
-      Butcher.addCmd "-next-binding" nextBinding
-      Butcher.addCmd "-Next-Binding" nextBinding
-      Butcher.addCmd "-NEXT-BINDING" nextBinding
-      let
-        disableNextBinding = do
-          Butcher.addCmdImpl
-            ( InlineConfigTargetNextBinding
-            , mempty { _conf_roundtrip_exactprint_only = pure $ pure True }
-            )
-      Butcher.addCmd "-disable-next-binding" disableNextBinding
-      Butcher.addCmd "-Disable-Next-Binding" disableNextBinding
-      Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding
-      let
-        disableNextDecl = do
-          Butcher.addCmdImpl
-            ( InlineConfigTargetNextDecl
-            , mempty { _conf_roundtrip_exactprint_only = pure $ pure True }
-            )
-      Butcher.addCmd "-disable-next-declaration" disableNextDecl
-      Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl
-      Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl
-      let
-        disableFormatting = do
-          Butcher.addCmdImpl
-            ( InlineConfigTargetModule
-            , mempty { _conf_disable_formatting = pure $ pure True }
-            )
-      Butcher.addCmd "-disable" disableFormatting
-      Butcher.addCmd "@" $ do
-        -- Butcher.addCmd "module" $ do
-        --   conf <- configParser
-        --   Butcher.addCmdImpl (InlineConfigTargetModule, conf)
-        Butcher.addNullCmd $ do
-          bindingName <- Butcher.addParamString "BINDING" mempty
-          conf <- configParser
-          Butcher.addCmdImpl (InlineConfigTargetBinding bindingName, conf)
-      conf <- configParser
-      Butcher.addCmdImpl (InlineConfigTargetModule, conf)
-  lineConfigss <- configLiness `forM` \(k, ss) -> do
-    r <- ss `forM` \s -> case Butcher.runCmdParserSimpleString s parser of
-      Left err -> Left $ (err, s)
-      Right c -> Right $ c
-    pure (k, r)
-
-  let
-    perModule = foldl'
-      (<>)
-      mempty
-      [ conf
-      | (_, lineConfigs) <- lineConfigss
-      , (InlineConfigTargetModule, conf) <- lineConfigs
-      ]
-  let
-    perBinding = Map.fromListWith
-      (<>)
-      [ (n, conf)
-      | (k, lineConfigs) <- lineConfigss
-      , (target, conf) <- lineConfigs
-      , n <- case target of
-        InlineConfigTargetBinding s -> [s]
-        InlineConfigTargetNextBinding | Just name <- Map.lookup k declNameMap ->
-          [name]
-        _ -> []
-      ]
-  let
-    perKey = Map.fromListWith
-      (<>)
-      [ (k, conf)
-      | (k, lineConfigs) <- lineConfigss
-      , (target, conf) <- lineConfigs
-      , case target of
-        InlineConfigTargetNextDecl -> True
-        InlineConfigTargetNextBinding | Nothing <- Map.lookup k declNameMap ->
-          True
-        _ -> False
-      ]
-
-  pure
-    $ ( perModule
-      , PerItemConfig { _icd_perBinding = perBinding, _icd_perKey = perKey }
-      )
-
-
-getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap
-getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) =
-  TopLevelDeclNameMap $ Map.fromList
-    [ (ExactPrint.mkAnnKey decl, name)
-    | decl <- decls
-    , (name : _) <- [getDeclBindingNames decl]
-    ]
-
-
 -- | 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.
@@ -238,143 +48,104 @@ getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) =
 -- `mask_`, so cannot be killed easily. If you don't control the input, you
 -- may wish to put some proper upper bound on the input's size as a timeout
 -- won't do.
-parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text)
+parsePrintModule
-parsePrintModule configWithDebugs inputText = runExceptT $ do
+  :: TraceFunc -> Config -> Text -> IO (Either [BrittanyError] Text)
-  let
+parsePrintModule traceFunc configWithDebugs inputText = runExceptT $ do
-    config = configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig }
+  let config =
+        configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig }
   let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
-  let config_pp = config & _conf_preprocessor
+  let config_pp  = config & _conf_preprocessor
-  let cppMode = config_pp & _ppconf_CPPMode & confUnpack
+  let cppMode    = config_pp & _ppconf_CPPMode & confUnpack @CPPMode
-  let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack
+  let hackAroundIncludes =
-  (anns, parsedSource, hasCPP) <- do
+        config_pp & _ppconf_hackAroundIncludes & confUnpack @Bool
-    let
+  (parsedSource, hasCPP) <- do
-      hackF s =
+    let hackF s = if "#include" `isPrefixOf` s
-        if "#include" `isPrefixOf` s then "-- BRITANY_INCLUDE_HACK " ++ s else s
+          then "-- BRITANY_INCLUDE_HACK " ++ s
-    let
+          else s
-      hackTransform = if hackAroundIncludes
+    let hackTransform = if hackAroundIncludes
-        then List.intercalate "\n" . fmap hackF . lines'
+          then List.intercalate "\n" . fmap hackF . lines'
-        else id
+          else id
-    let
+    let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
-      cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
+          then case cppMode of
-        then case cppMode of
+            CPPModeAbort  -> return $ Left "Encountered -XCPP. Aborting."
-          CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting."
+            CPPModeWarn   -> return $ Right True
-          CPPModeWarn -> return $ Right True
+            CPPModeNowarn -> return $ Right True
-          CPPModeNowarn -> return $ Right True
+          else return $ Right False
-        else return $ Right False
+    parseResult <- lift $ Parsing.parseModuleFromString
-    parseResult <- lift $ parseModuleFromString
       ghcOptions
       "stdin"
       cppCheckFunc
       (hackTransform $ Text.unpack inputText)
     case parseResult of
-      Left err -> throwE [ErrorInput err]
+      Left  err -> throwE [ErrorInput err]
-      Right x -> pure x
+      Right x   -> pure x
   (inlineConf, perItemConf) <-
-    either (throwE . (: []) . uncurry ErrorMacroConfig) pure
+    mapExceptT (fmap $ bimap (\(a, b) -> [ErrorMacroConfig a b]) id)
-      $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource)
+      $ extractCommentConfigs (useTraceFunc traceFunc) parsedSource
   let moduleConfig = cZipWith fromOptionIdentity config inlineConf
-  let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack
+  let disableFormatting =
+        moduleConfig & _conf_disable_formatting & confUnpack @Bool
   if disableFormatting
     then do
       return inputText
     else do
       (errsWarns, outputTextL) <- do
-        let
+        let omitCheck =
-          omitCheck =
+              moduleConfig
-            moduleConfig
+                & _conf_errorHandling
-              & _conf_errorHandling
+                & _econf_omit_output_valid_check
-              & _econf_omit_output_valid_check
+                & confUnpack
-              & confUnpack
         (ews, outRaw) <- if hasCPP || omitCheck
-          then return $ pPrintModule moduleConfig perItemConf anns parsedSource
+          then lift $ processModule traceFunc moduleConfig perItemConf parsedSource
-          else lift
+          else lift $ pPrintModuleAndCheck traceFunc
-            $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource
+                                           moduleConfig
-        let
+                                           perItemConf
-          hackF s = fromMaybe s
+                                           parsedSource
-            $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
+        let hackF s = fromMaybe s
+              $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
         pure $ if hackAroundIncludes
           then
             ( ews
             , TextL.intercalate (TextL.pack "\n")
-            $ hackF
+            $   hackF
             <$> TextL.splitOn (TextL.pack "\n") outRaw
             )
           else (ews, outRaw)
-      let
+      let customErrOrder ErrorInput{}          = 5
-        customErrOrder ErrorInput{} = 4
+          customErrOrder LayoutWarning{}       = 0 :: Int
-        customErrOrder LayoutWarning{} = 0 :: Int
+          customErrOrder ErrorOutputCheck{}    = 1
-        customErrOrder ErrorOutputCheck{} = 1
+          customErrOrder ErrorUnusedComment{}  = 2
-        customErrOrder ErrorUnusedComment{} = 2
+          customErrOrder ErrorUnusedComments{} = 3
-        customErrOrder ErrorUnknownNode{} = 3
+          customErrOrder ErrorUnknownNode{}    = 4
-        customErrOrder ErrorMacroConfig{} = 5
+          customErrOrder ErrorMacroConfig{}    = 6
-      let
+      let hasErrors =
-        hasErrors =
+            if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack
-          if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack
+              then not $ null errsWarns
-            then not $ null errsWarns
+              else 0 < maximum (-1 : fmap customErrOrder errsWarns)
-            else 0 < maximum (-1 : fmap customErrOrder errsWarns)
       if hasErrors
         then throwE $ errsWarns
         else pure $ TextL.toStrict outputTextL
 
 
 
--- 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.
-pPrintModule
-  :: Config
-  -> PerItemConfig
-  -> ExactPrint.Anns
-  -> GHC.ParsedSource
-  -> ([BrittanyError], TextL.Text)
-pPrintModule conf inlineConf anns parsedModule =
-  let
-    ((out, errs), debugStrings) =
-      runIdentity
-        $ MultiRWSS.runMultiRWSTNil
-        $ MultiRWSS.withMultiWriterAW
-        $ MultiRWSS.withMultiWriterAW
-        $ MultiRWSS.withMultiWriterW
-        $ MultiRWSS.withMultiReader anns
-        $ MultiRWSS.withMultiReader conf
-        $ MultiRWSS.withMultiReader inlineConf
-        $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns)
-        $ do
-            traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations
-              $ annsDoc anns
-            ppModule parsedModule
-    tracer = if Seq.null debugStrings
-      then id
-      else
-        trace ("---- DEBUGMESSAGES ---- ")
-          . foldr (seq . join trace) id debugStrings
-  in tracer $ (errs, Text.Builder.toLazyText out)
-  -- unless () $ do
-  --
-  --   debugStrings `forM_` \s ->
-  --     trace s $ return ()
-
 -- | Additionally checks that the output compiles again, appending an error
 -- if it does not.
 pPrintModuleAndCheck
-  :: Config
+  :: TraceFunc
+  -> Config
   -> PerItemConfig
-  -> ExactPrint.Anns
   -> GHC.ParsedSource
   -> IO ([BrittanyError], TextL.Text)
-pPrintModuleAndCheck conf inlineConf anns parsedModule = do
+pPrintModuleAndCheck traceFunc conf inlineConf parsedModule = do
-  let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity
+  let ghcOptions     = conf & _conf_forward & _options_ghc & runIdentity
-  let (errs, output) = pPrintModule conf inlineConf anns parsedModule
+  (errs, output) <- processModule traceFunc conf inlineConf parsedModule
-  parseResult <- parseModuleFromString
+  parseResult <- Parsing.parseModuleFromString ghcOptions
-    ghcOptions
+                                               "output"
-    "output"
+                                               (\_ -> return $ Right ())
-    (\_ -> return $ Right ())
+                                               (TextL.unpack output)
-    (TextL.unpack output)
+  let errs' = errs ++ case parseResult of
-  let
+        Left{}  -> [ErrorOutputCheck]
-    errs' = errs ++ case parseResult of
+        Right{} -> []
-      Left{} -> [ErrorOutputCheck]
-      Right{} -> []
   return (errs', output)
 
 
@@ -383,42 +154,48 @@ pPrintModuleAndCheck conf inlineConf anns parsedModule = do
 parsePrintModuleTests :: Config -> String -> Text -> IO (Either String Text)
 parsePrintModuleTests conf filename input = do
   let inputStr = Text.unpack input
-  parseResult <- parseModuleFromString
+  parseResult <- Parsing.parseModuleFromString
     (conf & _conf_forward & _options_ghc & runIdentity)
     filename
     (const . pure $ Right ())
     inputStr
   case parseResult of
-    Left err -> return $ Left err
+    Left  err               -> return $ Left err
-    Right (anns, parsedModule, _) -> runExceptT $ do
+    Right (parsedModule, _) -> runExceptT $ do
       (inlineConf, perItemConf) <-
-        case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of
+        mapExceptT
-          Left err -> throwE $ "error in inline config: " ++ show err
+          (fmap (bimap (\(a, _) -> "when parsing inline config: " ++ a) id))
-          Right x -> pure x
+          $ extractCommentConfigs (\_ -> pure ()) parsedModule
       let moduleConf = cZipWith fromOptionIdentity conf inlineConf
-      let
+      let omitCheck =
-        omitCheck =
+            conf
-          conf
+              &  _conf_errorHandling
-            & _conf_errorHandling
+              .> _econf_omit_output_valid_check
-            .> _econf_omit_output_valid_check
+              .> confUnpack
-            .> confUnpack
       (errs, ltext) <- if omitCheck
-        then return $ pPrintModule moduleConf perItemConf anns parsedModule
+        then lift $ processModule (TraceFunc $ \_ -> pure ())
-        else lift
+                                   moduleConf
-          $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule
+                                   perItemConf
+                                   parsedModule
+        else lift $ pPrintModuleAndCheck (TraceFunc $ \_ -> pure ())
+                                         moduleConf
+                                         perItemConf
+                                         parsedModule
       if null errs
         then pure $ TextL.toStrict $ ltext
-        else
+        else throwE
-          let
+          $  "pretty printing error(s):\n"
-            errStrs = errs <&> \case
+          ++ List.unlines (errorToString <$> errs)
-              ErrorInput str -> str
+ where
-              ErrorUnusedComment str -> str
+  errorToString :: BrittanyError -> String
-              LayoutWarning str -> str
+  errorToString = \case
-              ErrorUnknownNode str _ -> str
+    ErrorInput         str    -> str
-              ErrorMacroConfig str _ -> "when parsing inline config: " ++ str
+    ErrorUnusedComment _      -> "ErrorUnusedComment"
-              ErrorOutputCheck -> "Output is not syntactically valid."
+    ErrorUnusedComments _ _ _ -> "ErrorUnusedComments"
-          in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs
+    LayoutWarning str         -> str
-
+    ErrorUnknownNode str _    -> str
+    ErrorMacroConfig str _    -> "when parsing inline config: " ++ 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.
@@ -453,142 +230,7 @@ parsePrintModuleTests conf filename input = do
 --           Left $ "pretty printing error(s):\n" ++ List.unlines errStrs
 --         else return $ TextL.toStrict $ Text.Builder.toLazyText out
 
-toLocal :: Config -> ExactPrint.Anns -> PPMLocal a -> PPM a
-toLocal conf anns m = do
-  (x, write) <-
-    lift $ MultiRWSS.runMultiRWSTAW (conf :+: anns :+: HNil) HNil $ m
-  MultiRWSS.mGetRawW >>= \w -> MultiRWSS.mPutRawW (w `mappend` write)
-  pure x
 
-ppModule :: GenLocated SrcSpan HsModule -> PPM ()
-ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do
-  defaultAnns <- do
-    anns <- mAsk
-    let annKey = ExactPrint.mkAnnKey lmod
-    let annMap = Map.findWithDefault Map.empty annKey anns
-    let isEof = (== ExactPrint.AnnEofPos)
-    let overAnnsDP f a = a { ExactPrint.annsDP = f $ ExactPrint.annsDP a }
-    pure $ fmap (overAnnsDP . filter $ isEof . fst) annMap
-
-  post <- ppPreamble lmod
-  decls `forM_` \decl -> do
-    let declAnnKey = ExactPrint.mkAnnKey decl
-    let declBindingNames = getDeclBindingNames decl
-    inlineConf <- mAsk
-    let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf
-    let
-      mBindingConfs =
-        declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf
-    filteredAnns <- mAsk <&> \annMap ->
-      Map.union defaultAnns $ Map.findWithDefault Map.empty declAnnKey annMap
-
-    traceIfDumpConf
-        "bridoc annotations filtered/transformed"
-        _dconf_dump_annotations
-      $ annsDoc filteredAnns
-
-    config <- mAsk
-
-    let
-      config' = cZipWith fromOptionIdentity config
-        $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf]))
-
-    let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack
-    toLocal config' filteredAnns $ do
-      bd <- if exactprintOnly
-        then briDocMToPPM $ briDocByExactNoComment decl
-        else do
-          (r, errs, debugs) <- briDocMToPPMInner $ layoutDecl decl
-          mTell debugs
-          mTell errs
-          if null errs
-            then pure r
-            else briDocMToPPM $ briDocByExactNoComment decl
-      layoutBriDoc bd
-
-  let
-    finalComments = filter
-      (fst .> \case
-        ExactPrint.AnnComment{} -> True
-        _ -> False
-      )
-      post
-  post `forM_` \case
-    (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do
-      ppmMoveToExactLoc l
-      mTell $ Text.Builder.fromString cmStr
-    (ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) ->
-      let
-        folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of
-          ExactPrint.AnnComment cm | span <- ExactPrint.commentIdentifier cm ->
-            ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span
-            , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span
-            )
-          _ -> (acc + y, x)
-        (cmY, cmX) = foldl' folder (0, 0) finalComments
-      in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX)
-    _ -> return ()
-
-getDeclBindingNames :: LHsDecl GhcPs -> [String]
-getDeclBindingNames (L _ decl) = case decl of
-  SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n)
-  ValD _ (FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n]
-  _ -> []
-
-
--- Prints the information associated with the module annotation
--- This includes the imports
-ppPreamble
-  :: GenLocated SrcSpan HsModule
-  -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)]
-ppPreamble lmod@(L loc m@HsModule{}) = do
-  filteredAnns <- mAsk <&> \annMap ->
-    Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap
-    -- Since ghc-exactprint adds annotations following (implicit)
-    -- modules to both HsModule and the elements in the module
-    -- this can cause duplication of comments. So strip
-    -- attached annotations that come after the module's where
-    -- from the module node
-  config <- mAsk
-  let
-    shouldReformatPreamble =
-      config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack
-
-  let
-    (filteredAnns', post) =
-      case Map.lookup (ExactPrint.mkAnnKey lmod) filteredAnns of
-        Nothing -> (filteredAnns, [])
-        Just mAnn ->
-          let
-            modAnnsDp = ExactPrint.annsDP mAnn
-            isWhere (ExactPrint.G AnnWhere) = True
-            isWhere _ = False
-            isEof (ExactPrint.AnnEofPos) = True
-            isEof _ = False
-            whereInd = List.findIndex (isWhere . fst) modAnnsDp
-            eofInd = List.findIndex (isEof . fst) modAnnsDp
-            (pre, post') = case (whereInd, eofInd) of
-              (Nothing, Nothing) -> ([], modAnnsDp)
-              (Just i, Nothing) -> List.splitAt (i + 1) modAnnsDp
-              (Nothing, Just _i) -> ([], modAnnsDp)
-              (Just i, Just j) -> List.splitAt (min (i + 1) j) modAnnsDp
-            mAnn' = mAnn { ExactPrint.annsDP = pre }
-            filteredAnns'' =
-              Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns
-          in (filteredAnns'', post')
-  traceIfDumpConf
-      "bridoc annotations filtered/transformed"
-      _dconf_dump_annotations
-    $ annsDoc filteredAnns'
-
-  if shouldReformatPreamble
-    then toLocal config filteredAnns' $ withTransformedAnns lmod $ do
-      briDoc <- briDocMToPPM $ layoutModule lmod
-      layoutBriDoc briDoc
-    else
-      let emptyModule = L loc m { hsmodDecls = [] }
-      in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule
-  return post
 
 _sigHead :: Sig GhcPs -> String
 _sigHead = \case
@@ -600,86 +242,7 @@ _bindHead :: HsBind GhcPs -> String
 _bindHead = \case
   FunBind _ fId _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId)
   PatBind _ _pat _ ([], []) -> "PatBind smth"
-  _ -> "unknown bind"
+  _                         -> "unknown bind"
 
 
 
-layoutBriDoc :: BriDocNumbered -> PPMLocal ()
-layoutBriDoc briDoc = do
-  -- first step: transform the briDoc.
-  briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do
-    -- Note that briDoc is BriDocNumbered, but state type is BriDoc.
-    -- That's why the alt-transform looks a bit special here.
-    traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw
-      $ briDocToDoc
-      $ unwrapBriDocNumbered
-      $ briDoc
-    -- bridoc transformation: remove alts
-    transformAlts briDoc >>= mSet
-    mGet
-      >>= briDocToDoc
-      .> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt
-    -- bridoc transformation: float stuff in
-    mGet >>= transformSimplifyFloating .> mSet
-    mGet
-      >>= briDocToDoc
-      .> traceIfDumpConf
-           "bridoc post-floating"
-           _dconf_dump_bridoc_simpl_floating
-    -- bridoc transformation: par removal
-    mGet >>= transformSimplifyPar .> mSet
-    mGet
-      >>= briDocToDoc
-      .> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par
-    -- bridoc transformation: float stuff in
-    mGet >>= transformSimplifyColumns .> mSet
-    mGet
-      >>= briDocToDoc
-      .> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns
-    -- bridoc transformation: indent
-    mGet >>= transformSimplifyIndent .> mSet
-    mGet
-      >>= briDocToDoc
-      .> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent
-    mGet
-      >>= briDocToDoc
-      .> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final
-    -- -- convert to Simple type
-    -- simpl <- mGet <&> transformToSimple
-    -- return simpl
-
-  anns :: ExactPrint.Anns <- mAsk
-
-  let
-    state = LayoutState
-      { _lstate_baseYs = [0]
-      , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left
-                                           -- here because moveToAnn stuff
-                                           -- of the first node needs to do
-                                           -- its thing properly.
-      , _lstate_indLevels = [0]
-      , _lstate_indLevelLinger = 0
-      , _lstate_comments = anns
-      , _lstate_commentCol = Nothing
-      , _lstate_addSepSpace = Nothing
-      , _lstate_commentNewlines = 0
-      }
-
-  state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
-
-  let
-    remainingComments =
-      [ c
-      | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList
-        (_lstate_comments state')
-    -- With the new import layouter, we manually process comments
-    -- without relying on the backend to consume the comments out of
-    -- the state/map. So they will end up here, and we need to ignore
-    -- them.
-      , ExactPrint.unConName con /= "ImportDecl"
-      , c <- extractAllComments elemAnns
-      ]
-  remainingComments
-    `forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell)
-
-  return $ ()

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

@@ -0,0 +1,275 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DerivingStrategies #-}
+module Language.Haskell.Brittany.Internal.Components.BriDoc where
+
+import Language.Haskell.Brittany.Internal.Prelude
+
+import Data.Generics.Uniplate.Direct as Uniplate
+import qualified Data.Data
+import GHC (RealSrcLoc, LEpaComment)
+
+
+
+-- isomorphic to BriDocF Identity. Provided for ease of use, as we do a lot
+-- of transformations on `BriDocF Identity`s and it is really annoying to
+-- `Identity`/`runIdentity` everywhere.
+data BriDoc
+  = -- BDWrapAnnKey AnnKey BriDoc
+    BDEmpty
+  | BDLit !Text
+  | BDSeq [BriDoc] -- elements other than the last should
+                   -- not contains BDPars.
+  | BDCols ColSig [BriDoc] -- elements other than the last
+                         -- should not contains BDPars
+  | BDSeparator -- semantically, space-unless-at-end-of-line.
+  | BDAddBaseY BrIndent BriDoc
+  | BDBaseYPushCur BriDoc
+  | BDBaseYPop BriDoc
+  | BDIndentLevelPushCur BriDoc
+  | BDIndentLevelPop BriDoc
+  | BDPar
+    { _bdpar_indent :: BrIndent
+    , _bdpar_restOfLine :: BriDoc -- should not contain other BDPars
+    , _bdpar_indented :: BriDoc
+    }
+  -- | BDAddIndent BrIndent (BriDocF f)
+  -- | BDNewline
+  | BDAlt [BriDoc]
+  | BDForwardLineMode BriDoc
+  | BDExternal -- AnnKey
+               -- (Set AnnKey) -- set of annkeys contained within the node
+               --              -- to be printed via exactprint
+               Bool -- should print extra comment ?
+               Text
+  | BDPlain !Text -- used for QuasiQuotes, content can be multi-line
+                  -- (contrast to BDLit)
+  | BDQueueComments [LEpaComment] BriDoc
+      -- queue to be later flushed when the markers are reached
+  | BDFlushCommentsPrior RealSrcLoc BriDoc
+      -- process comments before loc from the queue
+  | BDFlushCommentsPost RealSrcLoc BriDoc
+      -- process comments before loc from the queue, but flow to end of
+      -- child-nodes
+  | BDLines [BriDoc]
+  | BDEnsureIndent BrIndent BriDoc
+  -- the following constructors are only relevant for the alt transformation
+  -- and are removed afterwards. They should never occur in any BriDoc
+  -- after the alt transformation.
+  | BDForceMultiline BriDoc
+  | BDForceSingleline BriDoc
+  | BDNonBottomSpacing Bool BriDoc
+  | BDSetParSpacing BriDoc
+  | BDForceParSpacing BriDoc
+  -- pseudo-deprecated
+  | BDDebug String BriDoc
+  deriving (Data.Data.Data, Eq, Ord)
+
+data BriDocF f
+  = -- BDWrapAnnKey AnnKey BriDoc
+    BDFEmpty
+  | BDFLit !Text
+  | BDFSeq [f (BriDocF f)] -- elements other than the last should
+                   -- not contains BDPars.
+  | BDFCols ColSig [f (BriDocF f)] -- elements other than the last
+                         -- should not contains BDPars
+  | BDFSeparator -- semantically, space-unless-at-end-of-line.
+  | BDFAddBaseY BrIndent (f (BriDocF f))
+  | BDFBaseYPushCur (f (BriDocF f))
+  | BDFBaseYPop (f (BriDocF f))
+  | BDFIndentLevelPushCur (f (BriDocF f))
+  | BDFIndentLevelPop (f (BriDocF f))
+  | BDFPar
+    { _bdfpar_indent :: BrIndent
+    , _bdfpar_restOfLine :: f (BriDocF f) -- should not contain other BDPars
+    , _bdfpar_indented :: f (BriDocF f)
+    }
+  -- | BDAddIndent BrIndent (BriDocF f)
+  -- | BDNewline
+  | BDFAlt [f (BriDocF f)]
+  | BDFForwardLineMode (f (BriDocF f))
+  | BDFExternal -- AnnKey
+                -- (Set AnnKey) -- set of annkeys contained within the node
+                --              -- to be printed via exactprint
+                Bool -- should print extra comment ?
+                Text
+  | BDFPlain !Text -- used for QuasiQuotes, content can be multi-line
+                   -- (contrast to BDLit)
+  | BDFQueueComments [LEpaComment] (f (BriDocF f))
+      -- ^ true = comments will be left in the queue when the node is left
+  | BDFFlushCommentsPrior RealSrcLoc (f (BriDocF f))
+      -- process comments before loc from the queue
+  | BDFFlushCommentsPost RealSrcLoc (f (BriDocF f))
+      -- process comments before loc from the queue, but flow to end of
+      -- child-nodes
+  | BDFLines [(f (BriDocF f))]
+  | BDFEnsureIndent BrIndent (f (BriDocF f))
+  | BDFForceMultiline (f (BriDocF f))
+  | BDFForceSingleline (f (BriDocF f))
+  | BDFNonBottomSpacing Bool (f (BriDocF f))
+  | BDFSetParSpacing (f (BriDocF f))
+  | BDFForceParSpacing (f (BriDocF f))
+  | BDFDebug String (f (BriDocF f))
+
+data BrIndent = BrIndentNone
+              | BrIndentRegular
+              | BrIndentSpecial Int
+  deriving (Eq, Ord, Data.Data.Data, Show)
+
+-- deriving instance Data.Data.Data (BriDocF Identity)
+deriving instance Data.Data.Data (BriDocF ((,) Int))
+
+type BriDocFInt = BriDocF ((,) Int)
+type BriDocNumbered = (Int, BriDocFInt)
+
+instance Uniplate.Uniplate BriDoc where
+  uniplate x@BDEmpty{}               = plate x
+  uniplate x@BDLit{}                 = plate x
+  uniplate (BDSeq list     )         = plate BDSeq ||* list
+  uniplate (BDCols sig list)         = plate BDCols |- sig ||* list
+  uniplate x@BDSeparator             = plate x
+  uniplate (BDAddBaseY ind bd      ) = plate BDAddBaseY |- ind |* bd
+  uniplate (BDBaseYPushCur       bd) = plate BDBaseYPushCur |* bd
+  uniplate (BDBaseYPop           bd) = plate BDBaseYPop |* bd
+  uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd
+  uniplate (BDIndentLevelPop     bd) = plate BDIndentLevelPop |* bd
+  uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented
+  uniplate (BDAlt             alts ) = plate BDAlt ||* alts
+  uniplate (BDForwardLineMode bd   ) = plate BDForwardLineMode |* bd
+  uniplate x@BDExternal{}            = plate x
+  uniplate x@BDPlain{}               = plate x
+  uniplate (BDQueueComments comms bd) =
+    plate BDQueueComments |- comms |* bd
+  uniplate (BDFlushCommentsPrior loc bd) =
+    plate BDFlushCommentsPrior |- loc |* bd
+  uniplate (BDFlushCommentsPost loc bd) =
+    plate BDFlushCommentsPost |- loc |* bd
+  uniplate (BDLines lines          ) = plate BDLines ||* lines
+  uniplate (BDEnsureIndent ind bd  ) = plate BDEnsureIndent |- ind |* bd
+  uniplate (BDForceMultiline  bd   ) = plate BDForceMultiline |* bd
+  uniplate (BDForceSingleline bd   ) = plate BDForceSingleline |* bd
+  uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd
+  uniplate (BDSetParSpacing   bd   ) = plate BDSetParSpacing |* bd
+  uniplate (BDForceParSpacing bd   ) = plate BDForceParSpacing |* bd
+  uniplate (BDDebug s bd           ) = plate BDDebug |- s |* bd
+
+-- this might not work. is not used anywhere either.
+briDocSeqSpine :: BriDoc -> ()
+briDocSeqSpine = \case
+  BDEmpty                        -> ()
+  BDLit _t                       -> ()
+  BDSeq list                     -> foldl' ((briDocSeqSpine .) . seq) () list
+  BDCols _sig list               -> foldl' ((briDocSeqSpine .) . seq) () list
+  BDSeparator                    -> ()
+  BDAddBaseY _ind bd             -> briDocSeqSpine bd
+  BDBaseYPushCur       bd        -> briDocSeqSpine bd
+  BDBaseYPop           bd        -> briDocSeqSpine bd
+  BDIndentLevelPushCur bd        -> briDocSeqSpine bd
+  BDIndentLevelPop     bd        -> briDocSeqSpine bd
+  BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented
+  BDAlt             alts         -> foldl' (\() -> briDocSeqSpine) () alts
+  BDForwardLineMode bd           -> briDocSeqSpine bd
+  BDExternal{}                   -> ()
+  BDPlain{}                      -> ()
+  BDQueueComments      _comms bd -> briDocSeqSpine bd
+  BDFlushCommentsPrior _loc   bd -> briDocSeqSpine bd
+  BDFlushCommentsPost  _loc   bd -> briDocSeqSpine bd
+  BDLines lines                  -> foldl' (\() -> briDocSeqSpine) () lines
+  BDEnsureIndent _ind bd         -> briDocSeqSpine bd
+  BDForceMultiline  bd           -> briDocSeqSpine bd
+  BDForceSingleline bd           -> briDocSeqSpine bd
+  BDNonBottomSpacing _ bd        -> briDocSeqSpine bd
+  BDSetParSpacing   bd           -> briDocSeqSpine bd
+  BDForceParSpacing bd           -> briDocSeqSpine bd
+  BDDebug _s bd                  -> briDocSeqSpine bd
+
+briDocForceSpine :: BriDoc -> BriDoc
+briDocForceSpine bd = briDocSeqSpine bd `seq` bd
+
+isNotEmpty :: BriDoc -> Bool
+isNotEmpty BDEmpty = False
+isNotEmpty _       = True
+
+-- TODO: rename to "dropLabels" ?
+unwrapBriDocNumbered :: BriDocNumbered -> BriDoc
+unwrapBriDocNumbered tpl = case snd tpl of
+  BDFEmpty                       -> BDEmpty
+  BDFLit t                       -> BDLit t
+  BDFSeq list                    -> BDSeq $ rec <$> list
+  BDFCols sig list               -> BDCols sig $ rec <$> list
+  BDFSeparator                   -> BDSeparator
+  BDFAddBaseY ind bd             -> BDAddBaseY ind $ rec bd
+  BDFBaseYPushCur       bd       -> BDBaseYPushCur $ rec bd
+  BDFBaseYPop           bd       -> BDBaseYPop $ rec bd
+  BDFIndentLevelPushCur bd       -> BDIndentLevelPushCur $ rec bd
+  BDFIndentLevelPop     bd       -> BDIndentLevelPop $ rec bd
+  BDFPar ind line indented       -> BDPar ind (rec line) (rec indented)
+  BDFAlt             alts        -> BDAlt $ rec <$> alts -- not that this will happen
+  BDFForwardLineMode bd          -> BDForwardLineMode $ rec bd
+  BDFExternal c t                -> BDExternal c t
+  BDFPlain t                     -> BDPlain t
+  BDFQueueComments      comms bd -> BDQueueComments comms $ rec bd
+  BDFFlushCommentsPrior loc   bd -> BDFlushCommentsPrior loc $ rec bd
+  BDFFlushCommentsPost  loc   bd -> BDFlushCommentsPost loc $ rec bd
+  BDFLines lines                 -> BDLines $ rec <$> lines
+  BDFEnsureIndent ind bd         -> BDEnsureIndent ind $ rec bd
+  BDFForceMultiline  bd          -> BDForceMultiline $ rec bd
+  BDFForceSingleline bd          -> BDForceSingleline $ rec bd
+  BDFNonBottomSpacing b bd       -> BDNonBottomSpacing b $ rec bd
+  BDFSetParSpacing   bd          -> BDSetParSpacing $ rec bd
+  BDFForceParSpacing bd          -> BDForceParSpacing $ rec bd
+  BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd
+  where rec = unwrapBriDocNumbered
+
+data ColSig
+  = ColTyOpPrefix
+    -- any prefixed operator/paren/"::"/..
+    -- expected to have exactly two colums.
+    -- e.g. ":: foo"
+    --       111222
+    --      "-> bar asd asd"
+    --       11122222222222
+  | ColPatternsFuncPrefix
+    -- pattern-part of the lhs, e.g. "func (foo a b) c _".
+    -- Has variable number of columns depending on the number of patterns.
+  | ColPatternsFuncInfix
+    -- pattern-part of the lhs, e.g. "Foo a <> Foo b".
+    -- Has variable number of columns depending on the number of patterns.
+  | ColPatterns
+  | ColCasePattern
+  | ColBindingLine (Maybe Text)
+    -- e.g. "func pat pat = expr"
+    --       1111111111111222222
+    -- or   "pat | stmt -> expr"
+    --       111111111112222222
+    -- expected to have exactly two columns.
+  | ColGuard
+    -- e.g. "func pat pat | cond = ..."
+    --       11111111111112222222
+    -- or   "pat | cond1, cond2 -> ..."
+    --       1111222222222222222
+    -- expected to have exactly two columns
+  | ColGuardedBody
+    -- e.g. | foofoo = 1
+    --      | bar    = 2
+    --      111111111222
+    -- expected to have exactly two columns
+  | ColBindStmt
+  | ColDoLet -- the non-indented variant
+  | ColRec
+  | ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect?
+  | ColRecDecl
+  | ColListComp
+  | ColList
+  | ColApp Text
+  | ColTuple
+  | ColTuples
+  | ColOpPrefix -- merge with ColList ? other stuff?
+  | ColImport
+
+  -- TODO
+  deriving (Eq, Ord, Data.Data.Data, Show)

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

@@ -1,6 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 
-module Language.Haskell.Brittany.Internal.Obfuscation where
+module Language.Haskell.Brittany.Internal.Components.Obfuscation where
 
 import Data.Char
 import qualified Data.Map as Map
@@ -8,7 +8,6 @@ import qualified Data.Set as Set
 import qualified Data.Text as Text
 import qualified GHC.OldList as List
 import Language.Haskell.Brittany.Internal.Prelude
-import Language.Haskell.Brittany.Internal.PreludeUtils
 import System.Random
 
 

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

@@ -1,7 +1,7 @@
 {-# LANGUAGE MonadComprehensions #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
-module Language.Haskell.Brittany.Internal.Config where
+module Language.Haskell.Brittany.Internal.Config.Config where
 
 import qualified Data.Bool as Bool
 import qualified Data.ByteString as ByteString
@@ -13,9 +13,8 @@ import qualified Data.Semigroup as Semigroup
 import qualified Data.Yaml
 import qualified GHC.OldList as List
 import Language.Haskell.Brittany.Internal.Config.Types
-import Language.Haskell.Brittany.Internal.Config.Types.Instances ()
+-- import Language.Haskell.Brittany.Internal.Config.Types.Instances ()
 import Language.Haskell.Brittany.Internal.Prelude
-import Language.Haskell.Brittany.Internal.PreludeUtils
 import Language.Haskell.Brittany.Internal.Utils
 import qualified System.Console.CmdArgs.Explicit as CmdArgs
 import qualified System.Directory
@@ -208,7 +207,9 @@ cmdlineConfigParser = do
 -- If the second parameter is True and the file does not exist, writes the
 -- staticDefaultConfig to the file.
 readConfig
-  :: MonadIO m => System.IO.FilePath -> MaybeT m (Maybe (CConfig Maybe))
+  :: (MonadIO m, Data.Yaml.FromJSON (CConfig Maybe))
+  => System.IO.FilePath
+  -> MaybeT m (Maybe (CConfig Maybe))
 readConfig path = do
   -- TODO: probably should catch IOErrors and then omit the existence check.
   exists <- liftIO $ System.Directory.doesFileExist path
@@ -230,7 +231,9 @@ readConfig path = do
 
 -- | Looks for a user-global config file and return its path.
 -- If there is no global config in a system, one will be created.
-userConfigPath :: IO System.IO.FilePath
+userConfigPath
+  :: (Data.Yaml.ToJSON (CConfig Maybe), CFunctor CConfig)
+  => IO System.IO.FilePath
 userConfigPath = do
   userBritPathSimple <- Directory.getAppUserDataDirectory "brittany"
   userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany"
@@ -257,7 +260,11 @@ findLocalConfigPath dir = do
 
 -- | Reads specified configs.
 readConfigs
-  :: CConfig Maybe        -- ^ Explicit options, take highest priority
+  :: ( Data.Yaml.FromJSON (CConfig Maybe)
+     , Monoid (CConfig Maybe)
+     , CZipWith CConfig
+     )
+  => CConfig Maybe        -- ^ Explicit options, take highest priority
   -> [System.IO.FilePath]  -- ^ List of config files to load and merge, highest priority first
   -> MaybeT IO Config
 readConfigs cmdlineConfig configPaths = do
@@ -270,19 +277,29 @@ readConfigs cmdlineConfig configPaths = do
 -- | Reads provided configs
 -- but also applies the user default configuration (with lowest priority)
 readConfigsWithUserConfig
-  :: CConfig Maybe        -- ^ Explicit options, take highest priority
+  :: ( Data.Yaml.ToJSON (CConfig Maybe)
+     , Data.Yaml.FromJSON (CConfig Maybe)
+     , Monoid (CConfig Maybe)
+     , CFunctor CConfig
+     , CZipWith CConfig
+     )
+  => CConfig Maybe        -- ^ Explicit options, take highest priority
   -> [System.IO.FilePath]  -- ^ List of config files to load and merge, highest priority first
   -> MaybeT IO Config
 readConfigsWithUserConfig cmdlineConfig configPaths = do
   defaultPath <- liftIO $ userConfigPath
   readConfigs cmdlineConfig (configPaths ++ [defaultPath])
 
-writeDefaultConfig :: MonadIO m => System.IO.FilePath -> m ()
+writeDefaultConfig
+  :: (MonadIO m, Data.Yaml.ToJSON (CConfig Maybe), CFunctor CConfig)
+  => System.IO.FilePath
+  -> m ()
 writeDefaultConfig path =
   liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap
     (Just . runIdentity)
     staticDefaultConfig
 
-showConfigYaml :: Config -> String
+showConfigYaml
+  :: (Data.Yaml.ToJSON (CConfig Maybe), CFunctor CConfig) => Config -> String
 showConfigYaml = Data.ByteString.Char8.unpack . Data.Yaml.encode . cMap
   (\(Identity x) -> Just x)

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

@@ -0,0 +1,194 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Language.Haskell.Brittany.Internal.Config.InlineParsing
+  ( extractCommentConfigs
+  )
+where
+
+import           Language.Haskell.Brittany.Internal.Prelude
+
+import qualified Data.ByteString.Char8
+import           Data.Char                      ( isSpace )
+import qualified Data.Map                      as Map
+import qualified Data.Yaml
+import qualified GHC
+import           GHC                            ( EpaComment(EpaComment)
+                                                , GenLocated(L)
+                                                )
+import qualified GHC.OldList                   as List
+import           GHC.Parser.Annotation          ( EpaCommentTok
+                                                  ( EpaBlockComment
+                                                  , EpaLineComment
+                                                  )
+                                                )
+import qualified UI.Butcher.Monadic            as Butcher
+-- import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
+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.Config.Types.Instances1 ()
+import Language.Haskell.Brittany.Internal.Config.Types.Instances2 ()
+-- import Language.Haskell.Brittany.Internal.Utils
+
+
+
+data InlineConfigTarget
+    = InlineConfigTargetModule
+    | InlineConfigTargetNextDecl    -- really only next in module
+    | InlineConfigTargetNextBinding -- by name
+    | InlineConfigTargetBinding String
+
+extractCommentConfigs
+  :: (String -> IO ())
+  -> GHC.ParsedSource
+  -> 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)
+  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
+    , Just line1                  <- case comm of
+      EpaLineComment l ->
+        [ List.stripPrefix "-- BRITTANY" l
+            <|> List.stripPrefix "--BRITTANY" l
+            <|> List.stripPrefix "-- brittany" l
+            <|> List.stripPrefix "--brittany" l
+        ]
+      EpaBlockComment l ->
+        [List.stripPrefix "{- BRITTANY" l >>= stripSuffix "-}"]
+      _ -> []
+    , let line2 = dropWhile isSpace line1
+    , (  ("@" `isPrefixOf` line2)
+      || ("-disable" `isPrefixOf` line2)
+      || ("-next" `isPrefixOf` line2)
+      || ("{" `isPrefixOf` line2)
+      || ("--" `isPrefixOf` line2)
+      )
+    ]
+  let perModule = foldl'
+        (<>)
+        mempty
+        [ conf | (_, InlineConfigTargetModule, conf) <- lineConfigs ]
+  let perBinding = Map.fromListWith
+        (<>)
+        [ (n, conf)
+        | (srcSpan, target, conf) <- lineConfigs
+        , let perBindRes = Map.lookupGT srcSpan declMap
+        , n <- case target of
+          InlineConfigTargetBinding s -> [s]
+          InlineConfigTargetNextBinding | Just (_, names) <- perBindRes -> names
+          _                           -> []
+        ]
+  let perSpan = Map.fromListWith
+        (<>)
+        [ (srcSpan, conf)
+        | (srcSpan, target, conf) <- lineConfigs
+        , let perBindRes = Map.lookupGT srcSpan declMap
+        , case target of
+          InlineConfigTargetNextDecl -> True
+          InlineConfigTargetNextBinding | Nothing <- perBindRes -> True
+          _                          -> False
+        ]
+
+  pure
+    $ ( perModule
+      , PerItemConfig { _icd_perBinding = perBinding, _icd_perAnchor = perSpan }
+      )
+ where
+  configParser = Butcher.addAlternatives
+    [ ( "commandline-config"
+      , \s -> "-" `isPrefixOf` dropWhile (== ' ') s
+      , cmdlineConfigParser
+      )
+    , ( "yaml-config-document"
+      , \s -> "{" `isPrefixOf` dropWhile (== ' ') s
+      , Butcher.addCmdPart (Butcher.varPartDesc "yaml-config-document")
+      $ either
+          (\_ -> Butcher.Failure Nothing)
+          (\lconf -> Butcher.Success (mempty { _conf_layout = lconf }) "")
+      . Data.Yaml.decodeEither'
+      . Data.ByteString.Char8.pack
+        -- TODO: use some proper utf8 encoder instead?
+      )
+    ]
+  parser = do -- we will (mis?)use butcher here to parse the inline config
+              -- line.
+    let nextDecl = do
+          conf <- configParser
+          Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf)
+    Butcher.addCmd "-next-declaration" nextDecl
+    Butcher.addCmd "-Next-Declaration" nextDecl
+    Butcher.addCmd "-NEXT-DECLARATION" nextDecl
+    let nextBinding = do
+          conf <- configParser
+          Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf)
+    Butcher.addCmd "-next-binding" nextBinding
+    Butcher.addCmd "-Next-Binding" nextBinding
+    Butcher.addCmd "-NEXT-BINDING" nextBinding
+    let disableNextBinding = do
+          Butcher.addCmdImpl
+            ( InlineConfigTargetNextBinding
+            , mempty { _conf_roundtrip_exactprint_only = pure $ pure True }
+            )
+    Butcher.addCmd "-disable-next-binding" disableNextBinding
+    Butcher.addCmd "-Disable-Next-Binding" disableNextBinding
+    Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding
+    let disableNextDecl = do
+          Butcher.addCmdImpl
+            ( InlineConfigTargetNextDecl
+            , mempty { _conf_roundtrip_exactprint_only = pure $ pure True }
+            )
+    Butcher.addCmd "-disable-next-declaration" disableNextDecl
+    Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl
+    Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl
+    let disableFormatting = do
+          Butcher.addCmdImpl
+            ( InlineConfigTargetModule
+            , mempty { _conf_disable_formatting = pure $ pure True }
+            )
+    Butcher.addCmd "-disable" disableFormatting
+    Butcher.addCmd "@" $ do
+      -- Butcher.addCmd "module" $ do
+      --   conf <- configParser
+      --   Butcher.addCmdImpl (InlineConfigTargetModule, conf)
+      Butcher.addNullCmd $ do
+        bindingName <- Butcher.addParamString "BINDING" mempty
+        conf        <- configParser
+        Butcher.addCmdImpl (InlineConfigTargetBinding bindingName, conf)
+    conf <- configParser
+    Butcher.addCmdImpl (InlineConfigTargetModule, conf)

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

@@ -7,19 +7,16 @@
 
 module Language.Haskell.Brittany.Internal.Config.Types where
 
-import Data.CZipWith
 import Data.Coerce (Coercible, coerce)
 import Data.Data (Data)
 import qualified Data.Semigroup as Semigroup
-import Data.Semigroup (Last)
-import Data.Semigroup.Generic
 import GHC.Generics
+import GHC (RealSrcSpan)
 import Language.Haskell.Brittany.Internal.Prelude
-import Language.Haskell.Brittany.Internal.PreludeUtils ()
 
 
 
-confUnpack :: Coercible a b => Identity a -> b
+confUnpack :: forall b a . Coercible a b => Identity a -> b
 confUnpack (Identity x) = coerce x
 
 data CDebugConfig f = DebugConfig
@@ -196,74 +193,10 @@ type ForwardOptions = CForwardOptions Identity
 type ErrorHandlingConfig = CErrorHandlingConfig Identity
 type Config = CConfig Identity
 
--- i wonder if any Show1 stuff could be leveraged.
+data PerItemConfig = PerItemConfig
-deriving instance Show (CDebugConfig Identity)
+  { _icd_perBinding :: Map String (CConfig Maybe)
-deriving instance Show (CLayoutConfig Identity)
+  , _icd_perAnchor :: Map RealSrcSpan (CConfig Maybe)
-deriving instance Show (CErrorHandlingConfig Identity)
+  }
-deriving instance Show (CForwardOptions Identity)
-deriving instance Show (CPreProcessorConfig Identity)
-deriving instance Show (CConfig Identity)
-
-deriving instance Show (CDebugConfig Maybe)
-deriving instance Show (CLayoutConfig Maybe)
-deriving instance Show (CErrorHandlingConfig Maybe)
-deriving instance Show (CForwardOptions Maybe)
-deriving instance Show (CPreProcessorConfig Maybe)
-deriving instance Show (CConfig Maybe)
-
-deriving instance Data (CDebugConfig Identity)
-deriving instance Data (CLayoutConfig Identity)
-deriving instance Data (CErrorHandlingConfig Identity)
-deriving instance Data (CForwardOptions Identity)
-deriving instance Data (CPreProcessorConfig Identity)
-deriving instance Data (CConfig Identity)
-
-deriving instance Data (CDebugConfig Maybe)
-deriving instance Data (CLayoutConfig Maybe)
-deriving instance Data (CErrorHandlingConfig Maybe)
-deriving instance Data (CForwardOptions Maybe)
-deriving instance Data (CPreProcessorConfig Maybe)
-deriving instance Data (CConfig Maybe)
-
-instance Semigroup.Semigroup (CDebugConfig Maybe) where
-  (<>) = gmappend
-instance Semigroup.Semigroup (CLayoutConfig Maybe) where
-  (<>) = gmappend
-instance Semigroup.Semigroup (CErrorHandlingConfig Maybe) where
-  (<>) = gmappend
-instance Semigroup.Semigroup (CForwardOptions Maybe) where
-  (<>) = gmappend
-instance Semigroup.Semigroup (CPreProcessorConfig Maybe) where
-  (<>) = gmappend
-instance Semigroup.Semigroup (CConfig Maybe) where
-  (<>) = gmappend
-
-instance Semigroup.Semigroup (CDebugConfig Identity) where
-  (<>) = gmappend
-instance Semigroup.Semigroup (CLayoutConfig Identity) where
-  (<>) = gmappend
-instance Semigroup.Semigroup (CErrorHandlingConfig Identity) where
-  (<>) = gmappend
-instance Semigroup.Semigroup (CForwardOptions Identity) where
-  (<>) = gmappend
-instance Semigroup.Semigroup (CPreProcessorConfig Identity) where
-  (<>) = gmappend
-instance Semigroup.Semigroup (CConfig Identity) where
-  (<>) = gmappend
-
-instance Monoid (CDebugConfig Maybe) where
-  mempty = gmempty
-instance Monoid (CLayoutConfig Maybe) where
-  mempty = gmempty
-instance Monoid (CErrorHandlingConfig Maybe) where
-  mempty = gmempty
-instance Monoid (CForwardOptions Maybe) where
-  mempty = gmempty
-instance Monoid (CPreProcessorConfig Maybe) where
-  mempty = gmempty
-instance Monoid (CConfig Maybe) where
-  mempty = gmempty
-
 
 data IndentPolicy = IndentPolicyLeft -- never create a new indentation at more
                                      -- than old indentation + amount
@@ -322,17 +255,3 @@ data ExactPrintFallbackMode
                                  -- THIS MAY THEORETICALLY CHANGE SEMANTICS OF
                                  -- A PROGRAM BY TRANSFORMING IT.
   deriving (Show, Generic, Data)
-
-deriveCZipWith ''CDebugConfig
-deriveCZipWith ''CLayoutConfig
-deriveCZipWith ''CErrorHandlingConfig
-deriveCZipWith ''CForwardOptions
-deriveCZipWith ''CPreProcessorConfig
-deriveCZipWith ''CConfig
-
-instance CFunctor CDebugConfig
-instance CFunctor CLayoutConfig
-instance CFunctor CErrorHandlingConfig
-instance CFunctor CForwardOptions
-instance CFunctor CPreProcessorConfig
-instance CFunctor CConfig

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

@@ -13,10 +13,12 @@
 {-# OPTIONS_GHC -fno-specialise #-}
 {-# OPTIONS_GHC -fignore-interface-pragmas #-}
 
-{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
 
-module Language.Haskell.Brittany.Internal.Config.Types.Instances where
+
+module Language.Haskell.Brittany.Internal.Config.Types.Instances1 where
 
 import qualified Data.Aeson.Key as Key
 import qualified Data.Aeson.Types as Aeson

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

@@ -0,0 +1,102 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+
+module Language.Haskell.Brittany.Internal.Config.Types.Instances2 where
+
+import Language.Haskell.Brittany.Internal.Config.Types
+import Language.Haskell.Brittany.Internal.Prelude
+import qualified Data.Semigroup as Semigroup
+import Data.Semigroup.Generic
+import Data.CZipWith
+import Data.Data(Data)
+
+
+
+-- i wonder if any Show1 stuff could be leveraged.
+deriving instance Show (CDebugConfig Identity)
+deriving instance Show (CLayoutConfig Identity)
+deriving instance Show (CErrorHandlingConfig Identity)
+deriving instance Show (CForwardOptions Identity)
+deriving instance Show (CPreProcessorConfig Identity)
+deriving instance Show (CConfig Identity)
+
+deriving instance Show (CDebugConfig Maybe)
+deriving instance Show (CLayoutConfig Maybe)
+deriving instance Show (CErrorHandlingConfig Maybe)
+deriving instance Show (CForwardOptions Maybe)
+deriving instance Show (CPreProcessorConfig Maybe)
+deriving instance Show (CConfig Maybe)
+
+instance Semigroup.Semigroup (CDebugConfig Maybe) where
+  (<>) = gmappend
+instance Semigroup.Semigroup (CLayoutConfig Maybe) where
+  (<>) = gmappend
+instance Semigroup.Semigroup (CErrorHandlingConfig Maybe) where
+  (<>) = gmappend
+instance Semigroup.Semigroup (CForwardOptions Maybe) where
+  (<>) = gmappend
+instance Semigroup.Semigroup (CPreProcessorConfig Maybe) where
+  (<>) = gmappend
+instance Semigroup.Semigroup (CConfig Maybe) where
+  (<>) = gmappend
+
+instance Semigroup.Semigroup (CDebugConfig Identity) where
+  (<>) = gmappend
+instance Semigroup.Semigroup (CLayoutConfig Identity) where
+  (<>) = gmappend
+instance Semigroup.Semigroup (CErrorHandlingConfig Identity) where
+  (<>) = gmappend
+instance Semigroup.Semigroup (CForwardOptions Identity) where
+  (<>) = gmappend
+instance Semigroup.Semigroup (CPreProcessorConfig Identity) where
+  (<>) = gmappend
+instance Semigroup.Semigroup (CConfig Identity) where
+  (<>) = gmappend
+
+instance Monoid (CDebugConfig Maybe) where
+  mempty = gmempty
+instance Monoid (CLayoutConfig Maybe) where
+  mempty = gmempty
+instance Monoid (CErrorHandlingConfig Maybe) where
+  mempty = gmempty
+instance Monoid (CForwardOptions Maybe) where
+  mempty = gmempty
+instance Monoid (CPreProcessorConfig Maybe) where
+  mempty = gmempty
+instance Monoid (CConfig Maybe) where
+  mempty = gmempty
+
+deriveCZipWith ''CDebugConfig
+deriveCZipWith ''CLayoutConfig
+deriveCZipWith ''CErrorHandlingConfig
+deriveCZipWith ''CForwardOptions
+deriveCZipWith ''CPreProcessorConfig
+deriveCZipWith ''CConfig
+
+instance CFunctor CDebugConfig
+instance CFunctor CLayoutConfig
+instance CFunctor CErrorHandlingConfig
+instance CFunctor CForwardOptions
+instance CFunctor CPreProcessorConfig
+instance CFunctor CConfig
+
+deriving instance Data PerItemConfig
+
+deriving instance Data (CDebugConfig Identity)
+deriving instance Data (CLayoutConfig Identity)
+deriving instance Data (CErrorHandlingConfig Identity)
+deriving instance Data (CForwardOptions Identity)
+deriving instance Data (CPreProcessorConfig Identity)
+deriving instance Data (CConfig Identity)
+
+deriving instance Data (CDebugConfig Maybe)
+deriving instance Data (CLayoutConfig Maybe)
+deriving instance Data (CErrorHandlingConfig Maybe)
+deriving instance Data (CForwardOptions Maybe)
+deriving instance Data (CPreProcessorConfig Maybe)
+deriving instance Data (CConfig Maybe)

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

@@ -1,254 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MonadComprehensions #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Language.Haskell.Brittany.Internal.ExactPrintUtils where
-
-import qualified Control.Monad.State.Class as State.Class
-import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
-import Data.Data
-import qualified Data.Foldable as Foldable
-import qualified Data.Generics as SYB
-import Data.HList.HList
-import qualified Data.Map as Map
-import qualified Data.Maybe
-import qualified Data.Sequence as Seq
-import qualified Data.Set as Set
-import GHC (GenLocated(L))
-import qualified GHC hiding (parseModule)
-import qualified GHC.Driver.CmdLine as GHC
-import GHC.Hs
-import qualified GHC.Types.SrcLoc as GHC
-import GHC.Types.SrcLoc (Located, SrcSpan)
-import Language.Haskell.Brittany.Internal.Config.Types
-import qualified Language.Haskell.Brittany.Internal.ParseModule as ParseModule
-import Language.Haskell.Brittany.Internal.Prelude
-import Language.Haskell.Brittany.Internal.PreludeUtils
-import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
-import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
-import qualified System.IO
-
-
-
-parseModule
-  :: [String]
-  -> System.IO.FilePath
-  -> (GHC.DynFlags -> IO (Either String a))
-  -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
-parseModule args fp dynCheck = do
-  str <- System.IO.readFile fp
-  parseModuleFromString args fp dynCheck str
-
-parseModuleFromString
-  :: [String]
-  -> System.IO.FilePath
-  -> (GHC.DynFlags -> IO (Either String a))
-  -> String
-  -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
-parseModuleFromString = ParseModule.parseModule
-
-
-commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform ()
-commentAnnFixTransformGlob ast = do
-  let
-    extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)
-    extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $
-      const Seq.empty
-        `SYB.ext1Q` (\l@(L span _) ->
-                      Seq.singleton (span, ExactPrint.mkAnnKey l)
-                    )
-  let nodes = SYB.everything (<>) extract ast
-  let
-    annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey
-    annsMap = Map.fromListWith
-      (const id)
-      [ (GHC.realSrcSpanEnd span, annKey)
-      | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes
-      ]
-  nodes `forM_` (snd .> processComs annsMap)
- where
-  processComs annsMap annKey1 = do
-    mAnn <- State.Class.gets fst <&> Map.lookup annKey1
-    mAnn `forM_` \ann1 -> do
-      let
-        priors = ExactPrint.annPriorComments ann1
-        follows = ExactPrint.annFollowingComments ann1
-        assocs = ExactPrint.annsDP ann1
-      let
-        processCom
-          :: (ExactPrint.Comment, ExactPrint.DeltaPos)
-          -> ExactPrint.TransformT Identity Bool
-        processCom comPair@(com, _) =
-          case GHC.realSrcSpanStart $ ExactPrint.commentIdentifier com of
-            comLoc -> case Map.lookupLE comLoc annsMap of
-              Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of
-                (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") ->
-                  move $> False
-                (x, y) | x == y -> move $> False
-                _ -> return True
-               where
-                ExactPrint.AnnKey annKeyLoc1 con1 = annKey1
-                ExactPrint.AnnKey annKeyLoc2 con2 = annKey2
-                loc1 = GHC.realSrcSpanStart annKeyLoc1
-                loc2 = GHC.realSrcSpanStart annKeyLoc2
-                move = ExactPrint.modifyAnnsT $ \anns ->
-                  let
-                    ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns
-                    ann2' = ann2
-                      { ExactPrint.annFollowingComments =
-                        ExactPrint.annFollowingComments ann2 ++ [comPair]
-                      }
-                  in Map.insert annKey2 ann2' anns
-              _ -> return True -- retain comment at current node.
-      priors' <- filterM processCom priors
-      follows' <- filterM processCom follows
-      assocs' <- flip filterM assocs $ \case
-        (ExactPrint.AnnComment com, dp) -> processCom (com, dp)
-        _ -> return True
-      let
-        ann1' = ann1
-          { ExactPrint.annPriorComments = priors'
-          , ExactPrint.annFollowingComments = follows'
-          , ExactPrint.annsDP = assocs'
-          }
-      ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns
-
-
--- TODO: this is unused by now, but it contains one detail that
---       commentAnnFixTransformGlob does not include: Moving of comments for
---       "RecordUpd"s.
--- commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform ()
--- commentAnnFixTransform modul = SYB.everything (>>) genF modul
---  where
---   genF :: Data.Data.Data a => a -> ExactPrint.Transform ()
---   genF = (\_ -> return ()) `SYB.extQ` exprF
---   exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform ()
---   exprF lexpr@(L _ expr) = case expr of
--- #if MIN_VERSION_ghc(8,6,0)   /* ghc-8.6 */
---     RecordCon _ _ (HsRecFields fs@(_:_) Nothing) ->
--- #else
---     RecordCon _ _ _ (HsRecFields fs@(_:_) Nothing) ->
--- #endif
---       moveTrailingComments lexpr (List.last fs)
--- #if MIN_VERSION_ghc(8,6,0)   /* ghc-8.6 */
---     RecordUpd _ _e fs@(_:_) ->
--- #else
---     RecordUpd _e fs@(_:_) _cons _ _ _ ->
--- #endif
---       moveTrailingComments lexpr (List.last fs)
---     _ -> return ()
-
--- commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform ()
--- commentAnnFixTransform modul = SYB.everything (>>) genF modul
---  where
---   genF :: Data.Data.Data a => a -> ExactPrint.Transform ()
---   genF = (\_ -> return ()) `SYB.extQ` exprF
---   exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform ()
---   exprF lexpr@(L _ expr) = case expr of
---     RecordCon _ _ (HsRecFields fs@(_:_) Nothing) ->
---       moveTrailingComments lexpr (List.last fs)
---     RecordUpd _ _e fs@(_:_) ->
---       moveTrailingComments lexpr (List.last fs)
---     _ -> return ()
-
--- moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b)
---                      => GHC.Located a -> GHC.Located b -> ExactPrint.Transform ()
--- moveTrailingComments astFrom astTo = do
---   let
---     k1 = ExactPrint.mkAnnKey astFrom
---     k2 = ExactPrint.mkAnnKey astTo
---     moveComments ans = ans'
---       where
---         an1 = Data.Maybe.fromJust $ Map.lookup k1 ans
---         an2 = Data.Maybe.fromJust $ Map.lookup k2 ans
---         cs1f = ExactPrint.annFollowingComments an1
---         cs2f = ExactPrint.annFollowingComments an2
---         (comments, nonComments) = flip breakEither (ExactPrint.annsDP an1)
---              $ \case
---                (ExactPrint.AnnComment com, dp) -> Left (com, dp)
---                x -> Right x
---         an1' = an1
---           { ExactPrint.annsDP               = nonComments
---           , ExactPrint.annFollowingComments = []
---           }
---         an2' = an2
---           { ExactPrint.annFollowingComments = cs1f ++ cs2f ++ comments
---           }
---         ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans
-
---   ExactPrint.modifyAnnsT moveComments
-
--- | split a set of annotations in a module into a map from top-level module
--- elements to the relevant annotations. Avoids quadratic behaviour a trivial
--- implementation would have.
-extractToplevelAnns
-  :: Located HsModule
-  -> ExactPrint.Anns
-  -> Map ExactPrint.AnnKey ExactPrint.Anns
-extractToplevelAnns lmod anns = output
- where
-  (L _ (HsModule _ _ _ _ ldecls _ _)) = lmod
-  declMap1 :: Map ExactPrint.AnnKey ExactPrint.AnnKey
-  declMap1 = Map.unions $ ldecls <&> \ldecl ->
-    Map.fromSet (const (ExactPrint.mkAnnKey ldecl)) (foldedAnnKeys ldecl)
-  declMap2 :: Map ExactPrint.AnnKey ExactPrint.AnnKey
-  declMap2 =
-    Map.fromList
-      $ [ (captured, declMap1 Map.! k)
-        | (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns
-        ]
-  declMap = declMap1 `Map.union` declMap2
-  modKey = ExactPrint.mkAnnKey lmod
-  output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns
-
-groupMap :: (Ord k, Ord l) => (k -> a -> l) -> Map k a -> Map l (Map k a)
-groupMap f = Map.foldlWithKey'
-  (\m k a -> Map.alter (insert k a) (f k a) m)
-  Map.empty
- where
-  insert k a Nothing = Just (Map.singleton k a)
-  insert k a (Just m) = Just (Map.insert k a m)
-
-foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey
-foldedAnnKeys ast = SYB.everything
-  Set.union
-  (\x -> maybe
-    Set.empty
-    Set.singleton
-    [ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x
-    | locTyCon == SYB.typeRepTyCon (SYB.typeOf x)
-    , l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x
-    ]
-      -- for some reason, ghc-8.8 has forgotten how to infer the type of l,
-      -- even though it is passed to mkAnnKey above, which only accepts
-      -- SrcSpan.
-  )
-  ast
-  where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ()))
-
-
-withTransformedAnns
-  :: Data ast
-  => ast
-  -> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a
-  -> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a
-withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case
-  readers@(conf :+: anns :+: HNil) -> do
-    -- TODO: implement `local` for MultiReader/MultiRWS
-    MultiRWSS.mPutRawR (conf :+: f anns :+: HNil)
-    x <- m
-    MultiRWSS.mPutRawR readers
-    pure x
- where
-  f anns =
-    let
-      ((), (annsBalanced, _), _) =
-        ExactPrint.runTransform anns (commentAnnFixTransformGlob ast)
-    in annsBalanced
-
-
-warnExtractorCompat :: GHC.Warn -> String
-warnExtractorCompat (GHC.Warn _ (L _ s)) = s

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

@@ -1,781 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Language.Haskell.Brittany.Internal.LayouterBasics where
-
-import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
-import qualified Control.Monad.Writer.Strict as Writer
-import qualified Data.Char as Char
-import Data.Data
-import qualified Data.Map as Map
-import qualified Data.Semigroup as Semigroup
-import qualified Data.Sequence as Seq
-import qualified Data.Set as Set
-import qualified Data.Text as Text
-import qualified Data.Text.Lazy.Builder as Text.Builder
-import DataTreePrint
-import GHC (GenLocated(L), Located, moduleName, moduleNameString)
-import qualified GHC.OldList as List
-import GHC.Parser.Annotation (AnnKeywordId(..))
-import GHC.Types.Name (getOccString)
-import GHC.Types.Name.Occurrence (occNameString)
-import GHC.Types.Name.Reader (RdrName(..))
-import qualified GHC.Types.SrcLoc as GHC
-import Language.Haskell.Brittany.Internal.Config.Types
-import Language.Haskell.Brittany.Internal.ExactPrintUtils
-import Language.Haskell.Brittany.Internal.Prelude
-import Language.Haskell.Brittany.Internal.PreludeUtils
-import Language.Haskell.Brittany.Internal.Types
-import Language.Haskell.Brittany.Internal.Utils
-import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
-import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate
-import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
-import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
-import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation)
-import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
-
-
-
-processDefault
-  :: ( ExactPrint.Annotate.Annotate ast
-     , MonadMultiWriter Text.Builder.Builder m
-     , MonadMultiReader ExactPrint.Types.Anns m
-     )
-  => Located ast
-  -> m ()
-processDefault x = do
-  anns <- mAsk
-  let str = ExactPrint.exactPrint x anns
-  -- 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 str
-
--- | Use ExactPrint's output for this node; add a newly generated inline comment
--- at insertion position (meant to point out to the user that this node is
--- not handled by brittany yet). Useful when starting implementing new
--- syntactic constructs when children are not handled yet.
-briDocByExact
-  :: (ExactPrint.Annotate.Annotate ast)
-  => Located ast
-  -> ToBriDocM BriDocNumbered
-briDocByExact ast = do
-  anns <- mAsk
-  traceIfDumpConf
-    "ast"
-    _dconf_dump_ast_unknown
-    (printTreeWithCustom 100 (customLayouterF anns) ast)
-  docExt ast anns True
-
--- | Use ExactPrint's output for this node.
--- Consider that for multi-line input, the indentation of the code produced
--- by ExactPrint might be different, and even incompatible with the indentation
--- of its surroundings as layouted by brittany. But there are safe uses of
--- this, e.g. for any top-level declarations.
-briDocByExactNoComment
-  :: (ExactPrint.Annotate.Annotate ast)
-  => Located ast
-  -> ToBriDocM BriDocNumbered
-briDocByExactNoComment ast = do
-  anns <- mAsk
-  traceIfDumpConf
-    "ast"
-    _dconf_dump_ast_unknown
-    (printTreeWithCustom 100 (customLayouterF anns) ast)
-  docExt ast anns False
-
--- | Use ExactPrint's output for this node, presuming that this output does
--- not contain any newlines. If this property is not met, the semantics
--- depend on the @econf_AllowRiskyExactPrintUse@ config flag.
-briDocByExactInlineOnly
-  :: (ExactPrint.Annotate.Annotate ast)
-  => String
-  -> Located ast
-  -> ToBriDocM BriDocNumbered
-briDocByExactInlineOnly infoStr ast = do
-  anns <- mAsk
-  traceIfDumpConf
-    "ast"
-    _dconf_dump_ast_unknown
-    (printTreeWithCustom 100 (customLayouterF anns) ast)
-  let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns
-  fallbackMode <-
-    mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack
-  let
-    exactPrintNode t = allocateNode $ BDFExternal
-      (ExactPrint.Types.mkAnnKey ast)
-      (foldedAnnKeys ast)
-      False
-      t
-  let
-    errorAction = do
-      mTell [ErrorUnknownNode infoStr ast]
-      docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"
-  case (fallbackMode, Text.lines exactPrinted) of
-    (ExactPrintFallbackModeNever, _) -> errorAction
-    (_, [t]) -> exactPrintNode
-      (Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t)
-    (ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted
-    _ -> errorAction
-
-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
-
-lrdrNameToText :: GenLocated l RdrName -> Text
-lrdrNameToText (L _ n) = rdrNameToText n
-
-lrdrNameToTextAnnGen
-  :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)
-  => (Text -> Text)
-  -> Located RdrName
-  -> m Text
-lrdrNameToTextAnnGen f ast@(L _ n) = do
-  anns <- mAsk
-  let t = f $ rdrNameToText n
-  let
-    hasUni x (ExactPrint.Types.G y, _) = x == y
-    hasUni _ _ = False
-  -- TODO: in general: we should _always_ process all annotaiton stuff here.
-  --       whatever we don't probably should have had some effect on the
-  --       output. in such cases, resorting to byExact is probably the safe
-  --       choice.
-  return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of
-    Nothing -> t
-    Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of
-      Exact{} | t == Text.pack "()" -> t
-      _ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`"
-      _ | any (hasUni AnnCommaTuple) aks -> t
-      _ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")"
-      _ | otherwise -> t
-
-lrdrNameToTextAnn
-  :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)
-  => Located RdrName
-  -> m Text
-lrdrNameToTextAnn = lrdrNameToTextAnnGen id
-
-lrdrNameToTextAnnTypeEqualityIsSpecial
-  :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)
-  => Located RdrName
-  -> m Text
-lrdrNameToTextAnnTypeEqualityIsSpecial ast = do
-  let
-    f x = if x == Text.pack "Data.Type.Equality~"
-      then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
-      else x
-  lrdrNameToTextAnnGen f ast
-
--- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects
--- the annotations for a (parent) node for a tick to be added to the
--- literal.
--- Excessively long name to reflect on us having to work around such
--- excessively obscure special cases in the exactprint API.
-lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick
-  :: ( Data ast
-     , MonadMultiReader Config m
-     , MonadMultiReader (Map AnnKey Annotation) m
-     )
-  => Located ast
-  -> Located RdrName
-  -> m Text
-lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do
-  hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote
-  x <- lrdrNameToTextAnn ast2
-  let
-    lit = if x == Text.pack "Data.Type.Equality~"
-      then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
-      else x
-  return $ if hasQuote then Text.cons '\'' lit else lit
-
-askIndent :: (MonadMultiReader Config m) => m Int
-askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk
-
-
-extractAllComments
-  :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)]
-extractAllComments ann =
-  ExactPrint.annPriorComments ann ++ extractRestComments ann
-
-extractRestComments
-  :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)]
-extractRestComments ann =
-  ExactPrint.annFollowingComments ann
-    ++ (ExactPrint.annsDP ann >>= \case
-         (ExactPrint.AnnComment com, dp) -> [(com, dp)]
-         _ -> []
-       )
-
-filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns
-filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast)
-
--- | True if there are any comments that are
--- a) connected to any node below (in AST sense) the given node AND
--- b) after (in source code order) the node.
-hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool
-hasAnyCommentsBelow ast@(L l _) =
-  List.any (\(c, _) -> ExactPrint.commentIdentifier c > ExactPrint.Utils.rs l)
-    <$> astConnectedComments ast
-
-hasCommentsBetween
-  :: Data ast
-  => GHC.Located ast
-  -> AnnKeywordId
-  -> AnnKeywordId
-  -> ToBriDocM Bool
-hasCommentsBetween ast leftKey rightKey = do
-  mAnn <- astAnn ast
-  let
-    go1 [] = False
-    go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest
-    go1 (_ : rest) = go1 rest
-    go2 [] = False
-    go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True
-    go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False
-    go2 (_ : rest) = go2 rest
-  case mAnn of
-    Nothing -> pure False
-    Just ann -> pure $ go1 $ ExactPrint.annsDP ann
-
--- | True if there are any comments that are connected to any node below (in AST
---   sense) the given node
-hasAnyCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool
-hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast
-
--- | True if there are any regular comments connected to any node below (in AST
---   sense) the given node
-hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool
-hasAnyRegularCommentsConnected ast =
-  any isRegularComment <$> astConnectedComments ast
-
--- | Regular comments are comments that are actually "source code comments",
--- i.e. things that start with "--" or "{-". In contrast to comment-annotations
--- used by ghc-exactprint for capturing symbols (and their exact positioning).
---
--- Only the type instance layouter makes use of this filter currently, but
--- it might make sense to apply it more aggressively or make it the default -
--- I believe that most of the time we branch on the existence of comments, we
--- only care about "regular" comments. We simply did not need the distinction
--- because "irregular" comments are not that common outside of type/data decls.
-isRegularComment :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> Bool
-isRegularComment = (== Nothing) . ExactPrint.Types.commentOrigin . fst
-
-astConnectedComments
-  :: Data ast
-  => GHC.Located ast
-  -> ToBriDocM [(ExactPrint.Types.Comment, ExactPrint.Types.DeltaPos)]
-astConnectedComments ast = do
-  anns <- filterAnns ast <$> mAsk
-  pure $ extractAllComments =<< Map.elems anns
-
-hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool
-hasAnyCommentsPrior ast = astAnn ast <&> \case
-  Nothing -> False
-  Just (ExactPrint.Types.Ann _ priors _ _ _ _) -> not $ null priors
-
-hasAnyRegularCommentsRest :: Data ast => GHC.Located ast -> ToBriDocM Bool
-hasAnyRegularCommentsRest ast = astAnn ast <&> \case
-  Nothing -> False
-  Just ann -> any isRegularComment (extractRestComments ann)
-
-hasAnnKeywordComment
-  :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool
-hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case
-  Nothing -> False
-  Just ann -> any hasK (extractAllComments ann)
-  where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst
-
-hasAnnKeyword
-  :: (Data a, MonadMultiReader (Map AnnKey Annotation) m)
-  => Located a
-  -> AnnKeywordId
-  -> m Bool
-hasAnnKeyword ast annKeyword = astAnn ast <&> \case
-  Nothing -> False
-  Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks
- where
-  hasK (ExactPrint.Types.G x, _) = x == annKeyword
-  hasK _ = False
-
-astAnn
-  :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m)
-  => GHC.Located ast
-  -> m (Maybe Annotation)
-astAnn ast = Map.lookup (ExactPrint.Types.mkAnnKey ast) <$> mAsk
-
--- new BriDoc stuff
-
-allocateNode
-  :: MonadMultiState NodeAllocIndex m => BriDocFInt -> m BriDocNumbered
-allocateNode bd = do
-  i <- allocNodeIndex
-  return (i, bd)
-
-allocNodeIndex :: MonadMultiState NodeAllocIndex m => m Int
-allocNodeIndex = do
-  NodeAllocIndex i <- mGet
-  mSet $ NodeAllocIndex (i + 1)
-  return i
-
--- docEmpty :: MonadMultiState NodeAllocIndex m => m BriDocNumbered
--- docEmpty = allocateNode BDFEmpty
---
--- docLit :: MonadMultiState NodeAllocIndex m => Text -> m BriDocNumbered
--- docLit t = allocateNode $ BDFLit t
---
--- docExt :: (ExactPrint.Annotate.Annotate ast, MonadMultiState NodeAllocIndex m)
---        => Located ast -> ExactPrint.Types.Anns -> Bool -> m BriDocNumbered
--- docExt x anns shouldAddComment = allocateNode $ BDFExternal
---                   (ExactPrint.Types.mkAnnKey x)
---                   (foldedAnnKeys x)
---                   shouldAddComment
---                   (Text.pack $ ExactPrint.exactPrint x anns)
---
--- docAlt :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered
--- docAlt l = allocateNode . BDFAlt =<< sequence l
---
---
--- docSeq :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered
--- docSeq l = allocateNode . BDFSeq =<< sequence l
---
--- docLines :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered
--- docLines l = allocateNode . BDFLines =<< sequence l
---
--- docCols :: MonadMultiState NodeAllocIndex m => ColSig -> [m BriDocNumbered] -> m BriDocNumbered
--- docCols sig l = allocateNode . BDFCols sig =<< sequence l
---
--- docAddBaseY :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered
--- docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm
---
--- docSetBaseY :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered
--- docSetBaseY bdm = allocateNode . BDFSetBaseY =<< bdm
---
--- docSetIndentLevel :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered
--- docSetIndentLevel bdm = allocateNode . BDFSetIndentLevel =<< bdm
---
--- docSeparator :: MonadMultiState NodeAllocIndex m => m BriDocNumbered
--- docSeparator = allocateNode BDFSeparator
---
--- docAnnotationPrior :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered
--- docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm
---
--- docAnnotationPost :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered
--- docAnnotationPost  annKey bdm = allocateNode . BDFAnnotationPost annKey =<< bdm
---
--- docNonBottomSpacing :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered
--- docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing =<< bdm
---
--- appSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered
--- appSep x = docSeq [x, docSeparator]
---
--- docCommaSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered
--- docCommaSep = appSep $ docLit $ Text.pack ","
---
--- docParenLSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered
--- docParenLSep = appSep $ docLit $ Text.pack "("
---
---
--- docPostComment :: (Data.Data.Data ast, MonadMultiState NodeAllocIndex m)
---                => Located ast
---                -> m BriDocNumbered
---                -> m BriDocNumbered
--- docPostComment ast bdm = do
---   bd <- bdm
---   allocateNode $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) bd
---
--- docWrapNode :: ( Data.Data.Data ast, MonadMultiState NodeAllocIndex m)
---             => Located ast
---             -> m BriDocNumbered
---             -> m BriDocNumbered
--- docWrapNode ast bdm = do
---   bd <- bdm
---   i1 <- allocNodeIndex
---   i2 <- allocNodeIndex
---   return
---     $ (,) i1
---     $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)
---     $ (,) i2
---     $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast)
---     $ bd
---
--- docPar :: MonadMultiState NodeAllocIndex m
---        => m BriDocNumbered
---        -> m BriDocNumbered
---        -> m BriDocNumbered
--- docPar lineM indentedM = do
---   line <- lineM
---   indented <- indentedM
---   allocateNode $ BDFPar BrIndentNone line indented
---
--- docForceSingleline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered
--- docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm
---
--- docForceMultiline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered
--- docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm
---
--- docEnsureIndent :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered
--- docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd
-
-docEmpty :: ToBriDocM BriDocNumbered
-docEmpty = allocateNode BDFEmpty
-
-docLit :: Text -> ToBriDocM BriDocNumbered
-docLit t = allocateNode $ BDFLit t
-
-docLitS :: String -> ToBriDocM BriDocNumbered
-docLitS s = allocateNode $ BDFLit $ Text.pack s
-
-docExt
-  :: (ExactPrint.Annotate.Annotate ast)
-  => Located ast
-  -> ExactPrint.Types.Anns
-  -> Bool
-  -> ToBriDocM BriDocNumbered
-docExt x anns shouldAddComment = allocateNode $ BDFExternal
-  (ExactPrint.Types.mkAnnKey x)
-  (foldedAnnKeys x)
-  shouldAddComment
-  (Text.pack $ ExactPrint.exactPrint x anns)
-
-docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
-docAlt l = allocateNode . BDFAlt =<< sequence l
-
-newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a)
-  deriving (Functor, Applicative, Monad)
-
-addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM ()
-addAlternativeCond cond doc = when cond (addAlternative doc)
-
-addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM ()
-addAlternative = CollectAltM . Writer.tell . (: [])
-
-runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered
-runFilteredAlternative (CollectAltM action) = docAlt $ Writer.execWriter action
-
-
-docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
-docSeq [] = docEmpty
-docSeq l = allocateNode . BDFSeq =<< sequence l
-
-docLines :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
-docLines l = allocateNode . BDFLines =<< sequence l
-
-docCols :: ColSig -> [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
-docCols sig l = allocateNode . BDFCols sig =<< sequence l
-
-docAddBaseY :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm
-
-docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-docSetBaseY bdm = do
-  bd <- bdm
-  -- the order here is important so that these two nodes can be treated
-  -- properly over at `transformAlts`.
-  n1 <- allocateNode $ BDFBaseYPushCur bd
-  n2 <- allocateNode $ BDFBaseYPop n1
-  return n2
-
-docSetIndentLevel :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-docSetIndentLevel bdm = do
-  bd <- bdm
-  n1 <- allocateNode $ BDFIndentLevelPushCur bd
-  n2 <- allocateNode $ BDFIndentLevelPop n1
-  return n2
-
-docSetBaseAndIndent :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-docSetBaseAndIndent = docSetBaseY . docSetIndentLevel
-
-docSeparator :: ToBriDocM BriDocNumbered
-docSeparator = allocateNode BDFSeparator
-
-docAnnotationPrior
-  :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-docAnnotationPrior annKey bdm =
-  allocateNode . BDFAnnotationPrior annKey =<< bdm
-
-docAnnotationKW
-  :: AnnKey
-  -> Maybe AnnKeywordId
-  -> ToBriDocM BriDocNumbered
-  -> ToBriDocM BriDocNumbered
-docAnnotationKW annKey kw bdm =
-  allocateNode . BDFAnnotationKW annKey kw =<< bdm
-
-docMoveToKWDP
-  :: AnnKey
-  -> AnnKeywordId
-  -> Bool
-  -> ToBriDocM BriDocNumbered
-  -> ToBriDocM BriDocNumbered
-docMoveToKWDP annKey kw shouldRestoreIndent bdm =
-  allocateNode . BDFMoveToKWDP annKey kw shouldRestoreIndent =<< bdm
-
-docAnnotationRest
-  :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-docAnnotationRest annKey bdm = allocateNode . BDFAnnotationRest annKey =<< bdm
-
-docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing False =<< bdm
-
-docNonBottomSpacingS :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-docNonBottomSpacingS bdm = allocateNode . BDFNonBottomSpacing True =<< bdm
-
-docSetParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-docSetParSpacing bdm = allocateNode . BDFSetParSpacing =<< bdm
-
-docForceParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-docForceParSpacing bdm = allocateNode . BDFForceParSpacing =<< bdm
-
-docDebug :: String -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-docDebug s bdm = allocateNode . BDFDebug s =<< bdm
-
-appSep :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-appSep x = docSeq [x, docSeparator]
-
-docCommaSep :: ToBriDocM BriDocNumbered
-docCommaSep = appSep $ docLit $ Text.pack ","
-
-docParenLSep :: ToBriDocM BriDocNumbered
-docParenLSep = appSep docParenL
-
--- TODO: we don't make consistent use of these (yet). However, I think the
--- most readable approach overall might be something else: define
--- `lit = docLit . Text.pack` and `prepSep = docSeq [docSeparator, x]`.
--- I think those two would make the usage most readable.
--- lit "("  and  appSep (lit "(")  are understandable and short without
--- introducing a new top-level binding for all types of parentheses.
-docParenL :: ToBriDocM BriDocNumbered
-docParenL = docLit $ Text.pack "("
-
-docParenR :: ToBriDocM BriDocNumbered
-docParenR = docLit $ Text.pack ")"
-
-docParenHashLSep :: ToBriDocM BriDocNumbered
-docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator]
-
-docParenHashRSep :: ToBriDocM BriDocNumbered
-docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"]
-
-docBracketL :: ToBriDocM BriDocNumbered
-docBracketL = docLit $ Text.pack "["
-
-docBracketR :: ToBriDocM BriDocNumbered
-docBracketR = docLit $ Text.pack "]"
-
-
-docTick :: ToBriDocM BriDocNumbered
-docTick = docLit $ Text.pack "'"
-
-docNodeAnnKW
-  :: Data.Data.Data ast
-  => Located ast
-  -> Maybe AnnKeywordId
-  -> ToBriDocM BriDocNumbered
-  -> ToBriDocM BriDocNumbered
-docNodeAnnKW ast kw bdm =
-  docAnnotationKW (ExactPrint.Types.mkAnnKey ast) kw bdm
-
-docNodeMoveToKWDP
-  :: Data.Data.Data ast
-  => Located ast
-  -> AnnKeywordId
-  -> Bool
-  -> ToBriDocM BriDocNumbered
-  -> ToBriDocM BriDocNumbered
-docNodeMoveToKWDP ast kw shouldRestoreIndent bdm =
-  docMoveToKWDP (ExactPrint.Types.mkAnnKey ast) kw shouldRestoreIndent bdm
-
-class DocWrapable a where
-  docWrapNode :: ( Data.Data.Data ast)
-              => Located ast
-              -> a
-              -> a
-  docWrapNodePrior :: ( Data.Data.Data ast)
-                   => Located ast
-                   -> a
-                   -> a
-  docWrapNodeRest  :: ( Data.Data.Data ast)
-                   => Located ast
-                   -> a
-                   -> a
-
-instance DocWrapable (ToBriDocM BriDocNumbered) where
-  docWrapNode ast bdm = do
-    bd <- bdm
-    i1 <- allocNodeIndex
-    i2 <- allocNodeIndex
-    return
-      $ (,) i1
-      $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)
-      $ (,) i2
-      $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast)
-      $ bd
-  docWrapNodePrior ast bdm = do
-    bd <- bdm
-    i1 <- allocNodeIndex
-    return $ (,) i1 $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) $ bd
-  docWrapNodeRest ast bdm = do
-    bd <- bdm
-    i2 <- allocNodeIndex
-    return $ (,) i2 $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) $ bd
-
-instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where
-  docWrapNode ast bdms = case bdms of
-    [] -> []
-    [bd] -> [docWrapNode ast bd]
-    (bd1 : bdR) | (bdN : bdM) <- reverse bdR ->
-      [docWrapNodePrior ast bd1] ++ reverse bdM ++ [docWrapNodeRest ast bdN]
-    _ -> error "cannot happen (TM)"
-  docWrapNodePrior ast bdms = case bdms of
-    [] -> []
-    [bd] -> [docWrapNodePrior ast bd]
-    (bd1 : bdR) -> docWrapNodePrior ast bd1 : bdR
-  docWrapNodeRest ast bdms = case reverse bdms of
-    [] -> []
-    (bdN : bdR) -> reverse $ docWrapNodeRest ast bdN : bdR
-
-instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where
-  docWrapNode ast bdsm = do
-    bds <- bdsm
-    case bds of
-      [] -> return [] -- TODO: this might be bad. maybe. then again, not really. well.
-      [bd] -> do
-        bd' <- docWrapNode ast (return bd)
-        return [bd']
-      (bd1 : bdR) | (bdN : bdM) <- reverse bdR -> do
-        bd1' <- docWrapNodePrior ast (return bd1)
-        bdN' <- docWrapNodeRest ast (return bdN)
-        return $ [bd1'] ++ reverse bdM ++ [bdN']
-      _ -> error "cannot happen (TM)"
-  docWrapNodePrior ast bdsm = do
-    bds <- bdsm
-    case bds of
-      [] -> return []
-      (bd1 : bdR) -> do
-        bd1' <- docWrapNodePrior ast (return bd1)
-        return (bd1' : bdR)
-  docWrapNodeRest ast bdsm = do
-    bds <- bdsm
-    case reverse bds of
-      [] -> return []
-      (bdN : bdR) -> do
-        bdN' <- docWrapNodeRest ast (return bdN)
-        return $ reverse (bdN' : bdR)
-
-instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where
-  docWrapNode ast bdsm = do
-    bds <- bdsm
-    case Seq.viewl bds of
-      Seq.EmptyL -> return Seq.empty -- TODO: this might be bad. maybe. then again, not really. well.
-      bd1 Seq.:< rest -> case Seq.viewr rest of
-        Seq.EmptyR -> do
-          bd1' <- docWrapNode ast (return bd1)
-          return $ Seq.singleton bd1'
-        bdM Seq.:> bdN -> do
-          bd1' <- docWrapNodePrior ast (return bd1)
-          bdN' <- docWrapNodeRest ast (return bdN)
-          return $ (bd1' Seq.<| bdM) Seq.|> bdN'
-  docWrapNodePrior ast bdsm = do
-    bds <- bdsm
-    case Seq.viewl bds of
-      Seq.EmptyL -> return Seq.empty
-      bd1 Seq.:< bdR -> do
-        bd1' <- docWrapNodePrior ast (return bd1)
-        return $ bd1' Seq.<| bdR
-  docWrapNodeRest ast bdsm = do
-    bds <- bdsm
-    case Seq.viewr bds of
-      Seq.EmptyR -> return Seq.empty
-      bdR Seq.:> bdN -> do
-        bdN' <- docWrapNodeRest ast (return bdN)
-        return $ bdR Seq.|> bdN'
-
-instance DocWrapable (ToBriDocM ([BriDocNumbered], BriDocNumbered, a)) where
-  docWrapNode ast stuffM = do
-    (bds, bd, x) <- stuffM
-    if null bds
-      then do
-        bd' <- docWrapNode ast (return bd)
-        return (bds, bd', x)
-      else do
-        bds' <- docWrapNodePrior ast (return bds)
-        bd' <- docWrapNodeRest ast (return bd)
-        return (bds', bd', x)
-  docWrapNodePrior ast stuffM = do
-    (bds, bd, x) <- stuffM
-    bds' <- docWrapNodePrior ast (return bds)
-    return (bds', bd, x)
-  docWrapNodeRest ast stuffM = do
-    (bds, bd, x) <- stuffM
-    bd' <- docWrapNodeRest ast (return bd)
-    return (bds, bd', x)
-
-
-
-docPar
-  :: ToBriDocM BriDocNumbered
-  -> ToBriDocM BriDocNumbered
-  -> ToBriDocM BriDocNumbered
-docPar lineM indentedM = do
-  line <- lineM
-  indented <- indentedM
-  allocateNode $ BDFPar BrIndentNone line indented
-
-docForceSingleline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm
-
-docForceMultiline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm
-
-docEnsureIndent
-  :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd
-
-unknownNodeError
-  :: Data.Data.Data ast
-  => String
-  -> GenLocated GHC.SrcSpan ast
-  -> ToBriDocM BriDocNumbered
-unknownNodeError infoStr ast = do
-  mTell [ErrorUnknownNode infoStr ast]
-  docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"
-
-spacifyDocs :: [ToBriDocM BriDocNumbered] -> [ToBriDocM BriDocNumbered]
-spacifyDocs [] = []
-spacifyDocs ds = fmap appSep (List.init ds) ++ [List.last ds]
-
-briDocMToPPM :: ToBriDocM a -> PPMLocal a
-briDocMToPPM m = do
-  (x, errs, debugs) <- briDocMToPPMInner m
-  mTell debugs
-  mTell errs
-  return x
-
-briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String)
-briDocMToPPMInner m = do
-  readers <- MultiRWSS.mGetRawR
-  let
-    ((x, errs), debugs) =
-      runIdentity
-        $ MultiRWSS.runMultiRWSTNil
-        $ MultiRWSS.withMultiStateA (NodeAllocIndex 1)
-        $ MultiRWSS.withMultiReaders readers
-        $ MultiRWSS.withMultiWriterAW
-        $ MultiRWSS.withMultiWriterAW
-        $ m
-  pure (x, errs, debugs)
-
-docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y)
-docSharedWrapper f x = return <$> f x

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

@@ -1,224 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Language.Haskell.Brittany.Internal.Layouters.IE where
-
-import qualified Data.List.Extra
-import qualified Data.Text as Text
-import GHC
-  ( AnnKeywordId(..)
-  , GenLocated(L)
-  , Located
-  , ModuleName
-  , moduleNameString
-  , unLoc
-  )
-import GHC.Hs
-import qualified GHC.OldList as List
-import Language.Haskell.Brittany.Internal.LayouterBasics
-import Language.Haskell.Brittany.Internal.Prelude
-import Language.Haskell.Brittany.Internal.Types
-import Language.Haskell.Brittany.Internal.Utils
-
-
-
-prepareName :: LIEWrappedName name -> Located name
-prepareName = ieLWrappedName
-
-layoutIE :: ToBriDoc IE
-layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
-  IEVar _ x -> layoutWrapped lie x
-  IEThingAbs _ x -> layoutWrapped lie x
-  IEThingAll _ x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]
-  IEThingWith _ x (IEWildcard _) _ _ ->
-    docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]
-  IEThingWith _ x _ ns _ -> do
-    hasComments <- orM
-      (hasCommentsBetween lie AnnOpenP AnnCloseP
-      : hasAnyCommentsBelow x
-      : map hasAnyCommentsBelow ns
-      )
-    let sortedNs = List.sortOn wrappedNameToText ns
-    runFilteredAlternative $ do
-      addAlternativeCond (not hasComments)
-        $ docSeq
-        $ [layoutWrapped lie x, docLit $ Text.pack "("]
-        ++ intersperse docCommaSep (map nameDoc sortedNs)
-        ++ [docParenR]
-      addAlternative
-        $ docWrapNodeRest lie
-        $ docAddBaseY BrIndentRegular
-        $ docPar (layoutWrapped lie x) (layoutItems (splitFirstLast sortedNs))
-   where
-    nameDoc = docLit <=< lrdrNameToTextAnn . prepareName
-    layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n]
-    layoutItems FirstLastEmpty = docSetBaseY $ docLines
-      [ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty]
-      , docParenR
-      ]
-    layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines
-      [ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n]
-      , docParenR
-      ]
-    layoutItems (FirstLast n1 nMs nN) =
-      docSetBaseY
-        $ docLines
-        $ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]]
-        ++ map layoutItem nMs
-        ++ [ docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN]
-           , docParenR
-           ]
-  IEModuleContents _ n -> docSeq
-    [ docLit $ Text.pack "module"
-    , docSeparator
-    , docLit . Text.pack . moduleNameString $ unLoc n
-    ]
-  _ -> docEmpty
- where
-  layoutWrapped _ = \case
-    L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n
-    L _ (IEPattern n) -> do
-      name <- lrdrNameToTextAnn n
-      docLit $ Text.pack "pattern " <> name
-    L _ (IEType n) -> do
-      name <- lrdrNameToTextAnn n
-      docLit $ Text.pack "type " <> name
-
-data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted
--- Helper function to deal with Located lists of LIEs.
--- In particular this will also associate documentation
--- from the located list that actually belongs to the last IE.
--- It also adds docCommaSep to all but the first element
--- This configuration allows both vertical and horizontal
--- handling of the resulting list. Adding parens is
--- left to the caller since that is context sensitive
-layoutAnnAndSepLLIEs
-  :: SortItemsFlag
-  -> Located [LIE GhcPs]
-  -> ToBriDocM [ToBriDocM BriDocNumbered]
-layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
-  let makeIENode ie = docSeq [docCommaSep, ie]
-  let
-    sortedLies =
-      [ items
-      | group <- Data.List.Extra.groupOn lieToText $ List.sortOn lieToText lies
-      , items <- mergeGroup group
-      ]
-  let
-    ieDocs = fmap layoutIE $ case shouldSort of
-      ShouldSortItems -> sortedLies
-      KeepItemsUnsorted -> lies
-  ieCommaDocs <-
-    docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of
-      FirstLastEmpty -> []
-      FirstLastSingleton ie -> [ie]
-      FirstLast ie1 ieMs ieN ->
-        [ie1] ++ map makeIENode ieMs ++ [makeIENode ieN]
-  pure $ fmap pure ieCommaDocs -- returned shared nodes
- where
-  mergeGroup :: [LIE GhcPs] -> [LIE GhcPs]
-  mergeGroup [] = []
-  mergeGroup items@[_] = items
-  mergeGroup items = if
-    | all isProperIEThing items -> [List.foldl1' thingFolder items]
-    | all isIEVar items -> [List.foldl1' thingFolder items]
-    | otherwise -> items
-  -- proper means that if it is a ThingWith, it does not contain a wildcard
-  -- (because I don't know what a wildcard means if it is not already a
-  -- IEThingAll).
-  isProperIEThing :: LIE GhcPs -> Bool
-  isProperIEThing = \case
-    L _ (IEThingAbs _ _wn) -> True
-    L _ (IEThingAll _ _wn) -> True
-    L _ (IEThingWith _ _wn NoIEWildcard _ _) -> True
-    _ -> False
-  isIEVar :: LIE GhcPs -> Bool
-  isIEVar = \case
-    L _ IEVar{} -> True
-    _ -> False
-  thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs
-  thingFolder l1@(L _ IEVar{}) _ = l1
-  thingFolder l1@(L _ IEThingAll{}) _ = l1
-  thingFolder _ l2@(L _ IEThingAll{}) = l2
-  thingFolder l1 (L _ IEThingAbs{}) = l1
-  thingFolder (L _ IEThingAbs{}) l2 = l2
-  thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2))
-    = L
-      l
-      (IEThingWith
-        x
-        wn
-        NoIEWildcard
-        (consItems1 ++ consItems2)
-        (fieldLbls1 ++ fieldLbls2)
-      )
-  thingFolder _ _ =
-    error "thingFolder should be exhaustive because we have a guard above"
-
-
--- Builds a complete layout for the given located
--- list of LIEs. The layout provides two alternatives:
--- (item, item, ..., item)
--- ( item
--- , item
--- ...
--- , item
--- )
--- If the llies contains comments the list will
--- always expand over multiple lines, even when empty:
--- () -- no comments
--- ( -- a comment
--- )
-layoutLLIEs
-  :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered
-layoutLLIEs enableSingleline shouldSort llies = do
-  ieDs <- layoutAnnAndSepLLIEs shouldSort llies
-  hasComments <- hasAnyCommentsBelow llies
-  runFilteredAlternative $ case ieDs of
-    [] -> do
-      addAlternativeCond (not hasComments) $ docLit $ Text.pack "()"
-      addAlternativeCond hasComments $ docPar
-        (docSeq [docParenLSep, docWrapNodeRest llies docEmpty])
-        docParenR
-    (ieDsH : ieDsT) -> do
-      addAlternativeCond (not hasComments && enableSingleline)
-        $ docSeq
-        $ [docLit (Text.pack "(")]
-        ++ (docForceSingleline <$> ieDs)
-        ++ [docParenR]
-      addAlternative
-        $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH])
-        $ docLines
-        $ ieDsT
-        ++ [docParenR]
-
--- | Returns a "fingerprint string", not a full text representation, nor even
--- a source code representation of this syntax node.
--- Used for sorting, not for printing the formatter's output source code.
-wrappedNameToText :: LIEWrappedName RdrName -> Text
-wrappedNameToText = \case
-  L _ (IEName n) -> lrdrNameToText n
-  L _ (IEPattern n) -> lrdrNameToText n
-  L _ (IEType n) -> lrdrNameToText n
-
--- | Returns a "fingerprint string", not a full text representation, nor even
--- a source code representation of this syntax node.
--- Used for sorting, not for printing the formatter's output source code.
-lieToText :: LIE GhcPs -> Text
-lieToText = \case
-  L _ (IEVar _ wn) -> wrappedNameToText wn
-  L _ (IEThingAbs _ wn) -> wrappedNameToText wn
-  L _ (IEThingAll _ wn) -> wrappedNameToText wn
-  L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn
-  -- TODO: These _may_ appear in exports!
-  -- Need to check, and either put them at the top (for module) or do some
-  -- other clever thing.
-  L _ (IEModuleContents _ n) -> moduleNameToText n
-  L _ IEGroup{} -> Text.pack "@IEGroup"
-  L _ IEDoc{} -> Text.pack "@IEDoc"
-  L _ IEDocNamed{} -> Text.pack "@IEDocNamed"
- where
-  moduleNameToText :: Located ModuleName -> Text
-  moduleNameToText (L _ name) =
-    Text.pack ("@IEModuleContents" ++ moduleNameString name)

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

@@ -1,197 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Language.Haskell.Brittany.Internal.Layouters.Module where
-
-import qualified Data.Maybe
-import qualified Data.Semigroup as Semigroup
-import qualified Data.Text as Text
-import GHC (AnnKeywordId(..), GenLocated(L), moduleNameString, unLoc)
-import GHC.Hs
-import qualified GHC.OldList as List
-import Language.Haskell.Brittany.Internal.Config.Types
-import Language.Haskell.Brittany.Internal.LayouterBasics
-import Language.Haskell.Brittany.Internal.Layouters.IE
-import Language.Haskell.Brittany.Internal.Layouters.Import
-import Language.Haskell.Brittany.Internal.Prelude
-import Language.Haskell.Brittany.Internal.PreludeUtils
-import Language.Haskell.Brittany.Internal.Types
-import Language.Haskell.GHC.ExactPrint as ExactPrint
-import Language.Haskell.GHC.ExactPrint.Types
-  (DeltaPos(..), commentContents, deltaRow)
-
-
-
-layoutModule :: ToBriDoc' HsModule
-layoutModule lmod@(L _ mod') = case mod' of
-    -- Implicit module Main
-  HsModule _ Nothing _ imports _ _ _ -> do
-    commentedImports <- transformToCommentedImport imports
-    -- groupify commentedImports `forM_` tellDebugMessShow
-    docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports)
-    -- sortedImports <- sortImports imports
-    -- docLines $ [layoutImport y i | (y, i) <- sortedImports]
-  HsModule _ (Just n) les imports _ _ _ -> do
-    commentedImports <- transformToCommentedImport imports
-    -- groupify commentedImports `forM_` tellDebugMessShow
-    -- sortedImports <- sortImports imports
-    let tn = Text.pack $ moduleNameString $ unLoc n
-    allowSingleLineExportList <-
-      mAsk <&> _conf_layout .> _lconfig_allowSingleLineExportList .> confUnpack
-    -- the config should not prevent single-line layout when there is no
-    -- export list
-    let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les
-    docLines
-      $ docSeq
-          [ docNodeAnnKW lmod Nothing docEmpty
-             -- A pseudo node that serves merely to force documentation
-             -- before the node
-          , docNodeMoveToKWDP lmod AnnModule True $ runFilteredAlternative $ do
-            addAlternativeCond allowSingleLine $ docForceSingleline $ docSeq
-              [ appSep $ docLit $ Text.pack "module"
-              , appSep $ docLit tn
-              , docWrapNode lmod $ appSep $ case les of
-                Nothing -> docEmpty
-                Just x -> layoutLLIEs True KeepItemsUnsorted x
-              , docSeparator
-              , docLit $ Text.pack "where"
-              ]
-            addAlternative $ docLines
-              [ docAddBaseY BrIndentRegular $ docPar
-                  (docSeq [appSep $ docLit $ Text.pack "module", docLit tn])
-                  (docSeq
-                    [ docWrapNode lmod $ case les of
-                      Nothing -> docEmpty
-                      Just x -> layoutLLIEs False KeepItemsUnsorted x
-                    , docSeparator
-                    , docLit $ Text.pack "where"
-                    ]
-                  )
-              ]
-          ]
-      : (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- [layoutImport y i | (y, i) <- sortedImports]
-
-data CommentedImport
-  = EmptyLine
-  | IndependentComment (Comment, DeltaPos)
-  | ImportStatement ImportStatementRecord
-
-instance Show CommentedImport where
-  show = \case
-    EmptyLine -> "EmptyLine"
-    IndependentComment _ -> "IndependentComment"
-    ImportStatement r ->
-      "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
-        (length $ commentsAfter r)
-
-data ImportStatementRecord = ImportStatementRecord
-  { commentsBefore :: [(Comment, DeltaPos)]
-  , commentsAfter :: [(Comment, DeltaPos)]
-  , importStatement :: ImportDecl GhcPs
-  }
-
-instance Show ImportStatementRecord where
-  show r =
-    "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
-      (length $ commentsAfter r)
-
-transformToCommentedImport
-  :: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport]
-transformToCommentedImport is = do
-  nodeWithAnnotations <- is `forM` \i@(L _ rawImport) -> do
-    annotionMay <- astAnn i
-    pure (annotionMay, rawImport)
-  let
-    convertComment (c, DP (y, x)) =
-      replicate (y - 1) EmptyLine ++ [IndependentComment (c, DP (1, x))]
-    accumF
-      :: [(Comment, DeltaPos)]
-      -> (Maybe Annotation, ImportDecl GhcPs)
-      -> ([(Comment, DeltaPos)], [CommentedImport])
-    accumF accConnectedComm (annMay, decl) = case annMay of
-      Nothing ->
-        ( []
-        , [ ImportStatement ImportStatementRecord
-              { commentsBefore = []
-              , commentsAfter = []
-              , importStatement = decl
-              }
-          ]
-        )
-      Just ann ->
-        let
-          blanksBeforeImportDecl = deltaRow (annEntryDelta ann) - 1
-          (newAccumulator, priorComments') =
-            List.span ((== 0) . deltaRow . snd) (annPriorComments ann)
-          go
-            :: [(Comment, DeltaPos)]
-            -> [(Comment, DeltaPos)]
-            -> ([CommentedImport], [(Comment, DeltaPos)], Int)
-          go acc [] = ([], acc, 0)
-          go acc [c1@(_, DP (y, _))] = ([], c1 : acc, y - 1)
-          go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs
-          go acc ((c1, DP (y, x)) : xs) =
-            ( (convertComment =<< xs) ++ replicate (y - 1) EmptyLine
-            , (c1, DP (1, x)) : acc
-            , 0
-            )
-          (convertedIndependentComments, beforeComments, initialBlanks) =
-            if blanksBeforeImportDecl /= 0
-              then (convertComment =<< priorComments', [], 0)
-              else go [] (reverse priorComments')
-        in
-          ( newAccumulator
-          , convertedIndependentComments
-          ++ replicate (blanksBeforeImportDecl + initialBlanks) EmptyLine
-          ++ [ ImportStatement ImportStatementRecord
-                 { commentsBefore = beforeComments
-                 , commentsAfter = accConnectedComm
-                 , importStatement = decl
-                 }
-             ]
-          )
-  let (finalAcc, finalList) = mapAccumR accumF [] nodeWithAnnotations
-  pure $ join $ (convertComment =<< finalAcc) : finalList
-
-sortCommentedImports :: [CommentedImport] -> [CommentedImport]
-sortCommentedImports =
-  unpackImports . mergeGroups . map (fmap (sortGroups)) . groupify
- where
-  unpackImports :: [CommentedImport] -> [CommentedImport]
-  unpackImports xs = xs >>= \case
-    l@EmptyLine -> [l]
-    l@IndependentComment{} -> [l]
-    ImportStatement r ->
-      map IndependentComment (commentsBefore r) ++ [ImportStatement r]
-  mergeGroups
-    :: [Either CommentedImport [ImportStatementRecord]] -> [CommentedImport]
-  mergeGroups xs = xs >>= \case
-    Left x -> [x]
-    Right y -> ImportStatement <$> y
-  sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord]
-  sortGroups =
-    List.sortOn (moduleNameString . unLoc . ideclName . importStatement)
-  groupify
-    :: [CommentedImport] -> [Either CommentedImport [ImportStatementRecord]]
-  groupify cs = go [] cs
-   where
-    go [] = \case
-      (l@EmptyLine : rest) -> Left l : go [] rest
-      (l@IndependentComment{} : rest) -> Left l : go [] rest
-      (ImportStatement r : rest) -> go [r] rest
-      [] -> []
-    go acc = \case
-      (l@EmptyLine : rest) -> Right (reverse acc) : Left l : go [] rest
-      (l@IndependentComment{} : rest) ->
-        Left l : Right (reverse acc) : go [] rest
-      (ImportStatement r : rest) -> go (r : acc) rest
-      [] -> [Right (reverse acc)]
-
-commentedImportsToDoc :: CommentedImport -> ToBriDocM BriDocNumbered
-commentedImportsToDoc = \case
-  EmptyLine -> docLitS ""
-  IndependentComment c -> commentToDoc c
-  ImportStatement r -> docSeq
-    (layoutImport (importStatement r) : map commentToDoc (commentsAfter r))
- where
-  commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c)

source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot

@@ -1,10 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Language.Haskell.Brittany.Internal.Layouters.Stmt where
-
-import GHC.Hs
-import Language.Haskell.Brittany.Internal.Types
-
-
-
-layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))

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

@@ -1,635 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Language.Haskell.Brittany.Internal.Layouters.Type where
-
-import qualified Data.Text as Text
-import GHC (AnnKeywordId(..), GenLocated(L))
-import GHC.Hs
-import qualified GHC.OldList as List
-import GHC.Types.Basic
-import GHC.Utils.Outputable (ftext, showSDocUnsafe)
-import Language.Haskell.Brittany.Internal.LayouterBasics
-import Language.Haskell.Brittany.Internal.Prelude
-import Language.Haskell.Brittany.Internal.PreludeUtils
-import Language.Haskell.Brittany.Internal.Types
-import Language.Haskell.Brittany.Internal.Utils
-  (FirstLastView(..), splitFirstLast)
-
-
-
-layoutType :: ToBriDoc HsType
-layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
-  -- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible"
-  HsTyVar _ promoted name -> do
-    t <- lrdrNameToTextAnnTypeEqualityIsSpecial name
-    case promoted of
-      IsPromoted -> docSeq [docSeparator, docTick, docWrapNode name $ docLit t]
-      NotPromoted -> docWrapNode name $ docLit t
-  HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do
-    let bndrs = getBinders hsf
-    typeDoc <- docSharedWrapper layoutType typ2
-    tyVarDocs <- layoutTyVarBndrs bndrs
-    cntxtDocs <- cntxts `forM` docSharedWrapper layoutType
-    let
-      maybeForceML = case typ2 of
-        (L _ HsFunTy{}) -> docForceMultiline
-        _ -> id
-    let
-      tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs
-      forallDoc = docAlt
-        [ let open = docLit $ Text.pack "forall"
-          in docSeq ([open] ++ tyVarDocLineList)
-        , 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 ")"
-              ]
-          )
-        ]
-      contextDoc = case cntxtDocs of
-        [] -> docLit $ Text.pack "()"
-        [x] -> x
-        _ -> docAlt
-          [ let
-              open = docLit $ Text.pack "("
-              close = docLit $ Text.pack ")"
-              list =
-                List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs
-            in docSeq ([open] ++ list ++ [close])
-          , let
-              open = docCols
-                ColTyOpPrefix
-                [docParenLSep, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs]
-              close = docLit $ Text.pack ")"
-              list = List.tail cntxtDocs <&> \cntxtDoc -> docCols
-                ColTyOpPrefix
-                [docCommaSep, docAddBaseY (BrIndentSpecial 2) cntxtDoc]
-            in docPar open $ docLines $ list ++ [close]
-          ]
-    docAlt
-      -- :: forall a b c . (Foo a b c) => a b -> c
-      [ docSeq
-        [ if null bndrs
-          then docEmpty
-          else
-            let
-              open = docLit $ Text.pack "forall"
-              close = docLit $ Text.pack " . "
-            in docSeq ([open, docSeparator] ++ tyVarDocLineList ++ [close])
-        , docForceSingleline contextDoc
-        , docLit $ Text.pack " => "
-        , docForceSingleline typeDoc
-        ]
-      -- :: forall a b c
-      --  . (Foo a b c)
-      -- => a b
-      -- -> c
-      , docPar
-        forallDoc
-        (docLines
-          [ docCols
-            ColTyOpPrefix
-            [ docWrapNodeRest ltype $ docLit $ Text.pack " . "
-            , docAddBaseY (BrIndentSpecial 3) $ contextDoc
-            ]
-          , docCols
-            ColTyOpPrefix
-            [ docLit $ Text.pack "=> "
-            , docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc
-            ]
-          ]
-        )
-      ]
-  HsForAllTy _ hsf typ2 -> do
-    let bndrs = getBinders hsf
-    typeDoc <- layoutType typ2
-    tyVarDocs <- layoutTyVarBndrs bndrs
-    let
-      maybeForceML = case typ2 of
-        (L _ HsFunTy{}) -> docForceMultiline
-        _ -> id
-    let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs
-    docAlt
-      -- forall x . x
-      [ docSeq
-        [ if null bndrs
-          then docEmpty
-          else
-            let
-              open = docLit $ Text.pack "forall"
-              close = docLit $ Text.pack " . "
-            in docSeq ([open] ++ tyVarDocLineList ++ [close])
-        , docForceSingleline $ return $ typeDoc
-        ]
-      -- :: forall x
-      --  . x
-      , docPar
-        (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList)
-        (docCols
-          ColTyOpPrefix
-          [ docWrapNodeRest ltype $ docLit $ Text.pack " . "
-          , maybeForceML $ return typeDoc
-          ]
-        )
-      -- :: 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 ")"
-              ]
-          )
-        ++ [ docCols
-               ColTyOpPrefix
-               [ docWrapNodeRest ltype $ docLit $ Text.pack " . "
-               , maybeForceML $ return typeDoc
-               ]
-           ]
-        )
-      ]
-  HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do
-    typeDoc <- docSharedWrapper layoutType typ1
-    cntxtDocs <- cntxts `forM` docSharedWrapper layoutType
-    let
-      contextDoc = docWrapNode lcntxts $ case cntxtDocs of
-        [] -> docLit $ Text.pack "()"
-        [x] -> x
-        _ -> docAlt
-          [ let
-              open = docLit $ Text.pack "("
-              close = docLit $ Text.pack ")"
-              list =
-                List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs
-            in docSeq ([open] ++ list ++ [close])
-          , let
-              open = docCols
-                ColTyOpPrefix
-                [docParenLSep, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs]
-              close = docLit $ Text.pack ")"
-              list = List.tail cntxtDocs <&> \cntxtDoc -> docCols
-                ColTyOpPrefix
-                [docCommaSep, docAddBaseY (BrIndentSpecial 2) $ cntxtDoc]
-            in docPar open $ docLines $ list ++ [close]
-          ]
-    let
-      maybeForceML = case typ1 of
-        (L _ HsFunTy{}) -> docForceMultiline
-        _ -> id
-    docAlt
-      -- (Foo a b c) => a b -> c
-      [ docSeq
-        [ docForceSingleline contextDoc
-        , docLit $ Text.pack " => "
-        , docForceSingleline typeDoc
-        ]
-      --    (Foo a b c)
-      -- => a b
-      -- -> c
-      , docPar
-        (docForceSingleline contextDoc)
-        (docCols
-          ColTyOpPrefix
-          [ docLit $ Text.pack "=> "
-          , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc
-          ]
-        )
-      ]
-  HsFunTy _ _ typ1 typ2 -> do
-    typeDoc1 <- docSharedWrapper layoutType typ1
-    typeDoc2 <- docSharedWrapper layoutType typ2
-    let
-      maybeForceML = case typ2 of
-        (L _ HsFunTy{}) -> docForceMultiline
-        _ -> id
-    hasComments <- hasAnyCommentsBelow ltype
-    docAlt
-      $ [ docSeq
-            [ appSep $ docForceSingleline typeDoc1
-            , appSep $ docLit $ Text.pack "->"
-            , docForceSingleline typeDoc2
-            ]
-        | not hasComments
-        ]
-      ++ [ docPar
-             (docNodeAnnKW ltype Nothing typeDoc1)
-             (docCols
-               ColTyOpPrefix
-               [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->"
-               , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc2
-               ]
-             )
-         ]
-  HsParTy _ typ1 -> do
-    typeDoc1 <- docSharedWrapper layoutType typ1
-    docAlt
-      [ docSeq
-        [ docWrapNodeRest ltype $ docLit $ Text.pack "("
-        , docForceSingleline typeDoc1
-        , docLit $ Text.pack ")"
-        ]
-      , docPar
-        (docCols
-          ColTyOpPrefix
-          [ docWrapNodeRest ltype $ docParenLSep
-          , docAddBaseY (BrIndentSpecial 2) $ typeDoc1
-          ]
-        )
-        (docLit $ Text.pack ")")
-      ]
-  HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do
-    let
-      gather
-        :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs])
-      gather list = \case
-        L _ (HsAppTy _ ty1 ty2) -> gather (ty2 : list) ty1
-        final -> (final, list)
-    let (typHead, typRest) = gather [typ2] typ1
-    docHead <- docSharedWrapper layoutType typHead
-    docRest <- docSharedWrapper layoutType `mapM` typRest
-    docAlt
-      [ docSeq
-      $ docForceSingleline docHead
-      : (docRest >>= \d -> [docSeparator, docForceSingleline d])
-      , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest)
-      ]
-  HsAppTy _ typ1 typ2 -> do
-    typeDoc1 <- docSharedWrapper layoutType typ1
-    typeDoc2 <- docSharedWrapper layoutType typ2
-    docAlt
-      [ docSeq
-        [docForceSingleline typeDoc1, docSeparator, docForceSingleline typeDoc2]
-      , docPar typeDoc1 (docEnsureIndent BrIndentRegular typeDoc2)
-      ]
-  HsListTy _ typ1 -> do
-    typeDoc1 <- docSharedWrapper layoutType typ1
-    docAlt
-      [ docSeq
-        [ docWrapNodeRest ltype $ docLit $ Text.pack "["
-        , docForceSingleline typeDoc1
-        , docLit $ Text.pack "]"
-        ]
-      , docPar
-        (docCols
-          ColTyOpPrefix
-          [ docWrapNodeRest ltype $ docLit $ Text.pack "[ "
-          , docAddBaseY (BrIndentSpecial 2) $ typeDoc1
-          ]
-        )
-        (docLit $ Text.pack "]")
-      ]
-  HsTupleTy _ tupleSort typs -> case tupleSort of
-    HsUnboxedTuple -> unboxed
-    HsBoxedTuple -> simple
-    HsConstraintTuple -> simple
-    HsBoxedOrConstraintTuple -> simple
-   where
-    unboxed = if null typs
-      then error "brittany internal error: unboxed unit"
-      else unboxedL
-    simple = if null typs then unitL else simpleL
-    unitL = docLit $ Text.pack "()"
-    simpleL = do
-      docs <- docSharedWrapper layoutType `mapM` typs
-      let
-        end = docLit $ Text.pack ")"
-        lines =
-          List.tail docs
-            <&> \d -> docAddBaseY (BrIndentSpecial 2)
-                  $ docCols ColTyOpPrefix [docCommaSep, d]
-        commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs)
-      docAlt
-        [ docSeq
-        $ [docLit $ Text.pack "("]
-        ++ docWrapNodeRest ltype commaDocs
-        ++ [end]
-        , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs]
-          in
-            docPar
-              (docAddBaseY (BrIndentSpecial 2) $ line1)
-              (docLines $ docWrapNodeRest ltype lines ++ [end])
-        ]
-    unboxedL = do
-      docs <- docSharedWrapper layoutType `mapM` typs
-      let
-        start = docParenHashLSep
-        end = docParenHashRSep
-      docAlt
-        [ docSeq
-        $ [start]
-        ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs)
-        ++ [end]
-        , let
-            line1 = docCols ColTyOpPrefix [start, head docs]
-            lines =
-              List.tail docs
-                <&> \d -> docAddBaseY (BrIndentSpecial 2)
-                      $ docCols ColTyOpPrefix [docCommaSep, d]
-          in docPar
-            (docAddBaseY (BrIndentSpecial 2) line1)
-            (docLines $ lines ++ [end])
-        ]
-  HsOpTy{} -> -- TODO
-    briDocByExactInlineOnly "HsOpTy{}" ltype
-  -- 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
-  --   --       parse result for any type level operators.
-  --   --       need to check how things are handled on the expression level.
-  --   let opStr = lrdrNameToText opName
-  --   let opLen = Text.length opStr
-  --   layouter1@(Layouter desc1 _ _) <- layoutType typ1
-  --   layouter2@(Layouter desc2 _ _) <- layoutType typ2
-  --   let line = do -- Maybe
-  --         l1 <- _ldesc_line desc1
-  --         l2 <- _ldesc_line desc2
-  --         let len1 = _lColumns_min l1
-  --         let len2 = _lColumns_min l2
-  --         let len = 2 + opLen + len1 + len2
-  --         return $ LayoutColumns
-  --           { _lColumns_key = ColumnKeyUnique
-  --           , _lColumns_lengths = [len]
-  --           , _lColumns_min = len
-  --           }
-  --   let block = do -- Maybe
-  --         rol1 <- descToBlockStart desc1
-  --         (min2, max2) <- descToMinMax (1+opLen) desc2
-  --         let (minR, maxR) = case descToBlockMinMax desc1 of
-  --               Nothing -> (min2, max2)
-  --               Just (min1, max1) -> (max min1 min2, max max1 max2)
-  --         return $ BlockDesc
-  --           { _bdesc_blockStart = rol1
-  --           , _bdesc_min = minR
-  --           , _bdesc_max = maxR
-  --           , _bdesc_opIndentFloatUp = Just (1+opLen)
-  --           }
-  --   return $ Layouter
-  --     { _layouter_desc = LayoutDesc
-  --       { _ldesc_line = line
-  --       , _ldesc_block = block
-  --       }
-  --     , _layouter_func = \params -> do
-  --         remaining <- getCurRemaining
-  --         let allowSameLine = _params_sepLines params /= SepLineTypeOp
-  --         case line of
-  --           Just (LayoutColumns _ _ m) | m <= remaining && allowSameLine -> do
-  --             applyLayouterRestore layouter1 defaultParams
-  --             layoutWriteAppend $ Text.pack " " <> opStr <> Text.pack " "
-  --             applyLayouterRestore layouter2 defaultParams
-  --           _ -> do
-  --             let upIndent   = maybe (1+opLen) (max (1+opLen)) $ _params_opIndent params
-  --             let downIndent = maybe upIndent (max upIndent) $ _bdesc_opIndentFloatUp =<< _ldesc_block desc2
-  --             layoutWithAddIndentN downIndent $ applyLayouterRestore layouter1 defaultParams
-  --             layoutWriteNewline
-  --             layoutWriteAppend $ opStr <> Text.pack " "
-  --             layoutWriteEnsureBlockPlusN downIndent
-  --             applyLayouterRestore layouter2 defaultParams
-  --               { _params_sepLines = SepLineTypeOp
-  --               , _params_opIndent = Just downIndent
-  --               }
-  --     , _layouter_ast = ltype
-  --     }
-  HsIParamTy _ (L _ (HsIPName ipName)) typ1 -> do
-    typeDoc1 <- docSharedWrapper layoutType typ1
-    docAlt
-      [ docSeq
-        [ docWrapNodeRest ltype $ docLit $ Text.pack
-          ("?" ++ showSDocUnsafe (ftext ipName) ++ "::")
-        , docForceSingleline typeDoc1
-        ]
-      , docPar
-        (docLit $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName)))
-        (docCols
-          ColTyOpPrefix
-          [ docWrapNodeRest ltype $ docLit $ Text.pack ":: "
-          , docAddBaseY (BrIndentSpecial 2) typeDoc1
-          ]
-        )
-      ]
-  -- TODO: test KindSig
-  HsKindSig _ typ1 kind1 -> do
-    typeDoc1 <- docSharedWrapper layoutType typ1
-    kindDoc1 <- docSharedWrapper layoutType kind1
-    hasParens <- hasAnnKeyword ltype AnnOpenP
-    docAlt
-      [ if hasParens
-        then docSeq
-          [ docLit $ Text.pack "("
-          , docForceSingleline typeDoc1
-          , docSeparator
-          , docLit $ Text.pack "::"
-          , docSeparator
-          , docForceSingleline kindDoc1
-          , docLit $ Text.pack ")"
-          ]
-        else docSeq
-          [ docForceSingleline typeDoc1
-          , docSeparator
-          , docLit $ Text.pack "::"
-          , docSeparator
-          , docForceSingleline kindDoc1
-          ]
-      , if hasParens
-        then docLines
-          [ docCols
-            ColTyOpPrefix
-            [ docWrapNodeRest ltype $ docParenLSep
-            , docAddBaseY (BrIndentSpecial 3) $ typeDoc1
-            ]
-          , docCols
-            ColTyOpPrefix
-            [ docWrapNodeRest ltype $ docLit $ Text.pack ":: "
-            , docAddBaseY (BrIndentSpecial 3) kindDoc1
-            ]
-          , (docLit $ Text.pack ")")
-          ]
-        else docPar
-          typeDoc1
-          (docCols
-            ColTyOpPrefix
-            [ docWrapNodeRest ltype $ docLit $ Text.pack ":: "
-            , docAddBaseY (BrIndentSpecial 3) kindDoc1
-            ]
-          )
-      ]
-  HsBangTy{} -> -- TODO
-    briDocByExactInlineOnly "HsBangTy{}" ltype
-  -- HsBangTy bang typ1 -> do
-  --   let bangStr = case bang of
-  --         HsSrcBang _ unpackness strictness ->
-  --           (++)
-  --             (case unpackness of
-  --               SrcUnpack   -> "{-# UNPACK -#} "
-  --               SrcNoUnpack -> "{-# NOUNPACK -#} "
-  --               NoSrcUnpack -> ""
-  --             )
-  --             (case strictness of
-  --               SrcLazy     -> "~"
-  --               SrcStrict   -> "!"
-  --               NoSrcStrict -> ""
-  --             )
-  --   let bangLen = length bangStr
-  --   layouter@(Layouter desc _ _) <- layoutType typ1
-  --   let line = do -- Maybe
-  --         l <- _ldesc_line desc
-  --         let len = bangLen + _lColumns_min l
-  --         return $ LayoutColumns
-  --           { _lColumns_key = ColumnKeyUnique
-  --           , _lColumns_lengths = [len]
-  --           , _lColumns_min = len
-  --           }
-  --   let block = do -- Maybe
-  --         rol <- descToBlockStart desc
-  --         (minR,maxR) <- descToBlockMinMax desc
-  --         return $ BlockDesc
-  --           { _bdesc_blockStart = rol
-  --           , _bdesc_min = minR
-  --           , _bdesc_max = maxR
-  --           , _bdesc_opIndentFloatUp = Nothing
-  --           }
-  --   return $ Layouter
-  --     { _layouter_desc = LayoutDesc
-  --       { _ldesc_line = line
-  --       , _ldesc_block = block
-  --       }
-  --     , _layouter_func = \_params -> do
-  --         remaining <- getCurRemaining
-  --         case line of
-  --           Just (LayoutColumns _ _ m) | m <= remaining -> do
-  --             layoutWriteAppend $ Text.pack $ bangStr
-  --             applyLayouterRestore layouter defaultParams
-  --           _ -> do
-  --             layoutWriteAppend $ Text.pack $ bangStr
-  --             layoutWritePostCommentsRestore ltype
-  --             applyLayouterRestore layouter defaultParams
-  --     , _layouter_ast = ltype
-  --     }
-  HsSpliceTy{} -> -- TODO
-    briDocByExactInlineOnly "HsSpliceTy{}" ltype
-  HsDocTy{} -> -- TODO
-    briDocByExactInlineOnly "HsDocTy{}" ltype
-  HsRecTy{} -> -- TODO
-    briDocByExactInlineOnly "HsRecTy{}" ltype
-  HsExplicitListTy _ _ typs -> do
-    typDocs <- docSharedWrapper layoutType `mapM` typs
-    hasComments <- hasAnyCommentsBelow ltype
-    let specialCommaSep = appSep $ docLit $ Text.pack " ,"
-    docAlt
-      [ docSeq
-      $ [docLit $ Text.pack "'["]
-      ++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs)
-      ++ [docLit $ Text.pack "]"]
-      , case splitFirstLast typDocs of
-        FirstLastEmpty -> docSeq
-          [ docLit $ Text.pack "'["
-          , docNodeAnnKW ltype (Just AnnOpenS) $ docLit $ Text.pack "]"
-          ]
-        FirstLastSingleton e -> docAlt
-          [ docSeq
-            [ docLit $ Text.pack "'["
-            , docNodeAnnKW ltype (Just AnnOpenS) $ docForceSingleline e
-            , docLit $ Text.pack "]"
-            ]
-          , docSetBaseY $ docLines
-            [ docSeq
-              [ docLit $ Text.pack "'["
-              , docSeparator
-              , docSetBaseY $ docNodeAnnKW ltype (Just AnnOpenS) e
-              ]
-            , docLit $ Text.pack " ]"
-            ]
-          ]
-        FirstLast e1 ems eN -> runFilteredAlternative $ do
-          addAlternativeCond (not hasComments)
-            $ docSeq
-            $ [docLit $ Text.pack "'["]
-            ++ List.intersperse
-                 specialCommaSep
-                 (docForceSingleline
-                 <$> (e1 : ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN])
-                 )
-            ++ [docLit $ Text.pack " ]"]
-          addAlternative
-            $ let
-                start = docCols ColList [appSep $ docLit $ Text.pack "'[", e1]
-                linesM = ems <&> \d -> docCols ColList [specialCommaSep, d]
-                lineN = docCols
-                  ColList
-                  [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN]
-                end = docLit $ Text.pack " ]"
-              in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]
-      ]
-  HsExplicitTupleTy{} -> -- TODO
-    briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype
-  HsTyLit _ lit -> case lit of
-    HsNumTy (SourceText srctext) _ -> docLit $ Text.pack srctext
-    HsNumTy NoSourceText _ ->
-      error "overLitValBriDoc: literal with no SourceText"
-    HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext
-    HsStrTy NoSourceText _ ->
-      error "overLitValBriDoc: literal with no SourceText"
-  HsWildCardTy _ -> docLit $ Text.pack "_"
-  HsSumTy{} -> -- TODO
-    briDocByExactInlineOnly "HsSumTy{}" ltype
-  HsStarTy _ isUnicode -> do
-    if isUnicode
-      then docLit $ Text.pack "\x2605" -- Unicode star
-      else docLit $ Text.pack "*"
-  XHsType{} -> error "brittany internal error: XHsType"
-  HsAppKindTy _ ty kind -> do
-    t <- docSharedWrapper layoutType ty
-    k <- docSharedWrapper layoutType kind
-    docAlt
-      [ docSeq
-        [ docForceSingleline t
-        , docSeparator
-        , docLit $ Text.pack "@"
-        , docForceSingleline k
-        ]
-      , docPar t (docSeq [docLit $ Text.pack "@", k])
-      ]
-
-layoutTyVarBndrs
-  :: [LHsTyVarBndr () GhcPs]
-  -> ToBriDocM [(Text, Maybe (ToBriDocM BriDocNumbered))]
-layoutTyVarBndrs = mapM $ \case
-  (L _ (UserTyVar _ _ name)) -> return $ (lrdrNameToText name, Nothing)
-  (L _ (KindedTyVar _ _ lrdrName kind)) -> do
-    d <- docSharedWrapper layoutType kind
-    return $ (lrdrNameToText lrdrName, Just $ d)
-
--- there is no specific reason this returns a list instead of a single
--- BriDoc node.
-processTyVarBndrsSingleline
-  :: [(Text, Maybe (ToBriDocM BriDocNumbered))] -> [ToBriDocM BriDocNumbered]
-processTyVarBndrsSingleline bndrDocs = bndrDocs >>= \case
-  (tname, Nothing) -> [docSeparator, docLit tname]
-  (tname, Just doc) ->
-    [ docSeparator
-    , docLit $ Text.pack "(" <> tname <> Text.pack " :: "
-    , docForceSingleline $ doc
-    , docLit $ Text.pack ")"
-    ]
-
-getBinders :: HsForAllTelescope pass -> [LHsTyVarBndr () pass]
-getBinders x = case x of
-  HsForAllVis _ b -> b
-  HsForAllInvis _ b -> fmap withoutSpecificity b
-  XHsForAllTelescope _ -> []
-
-withoutSpecificity :: LHsTyVarBndr flag pass -> LHsTyVarBndr () pass
-withoutSpecificity = fmap $ \case
-  UserTyVar a _ c -> UserTyVar a () c
-  KindedTyVar a _ c d -> KindedTyVar a () c d
-  XTyVarBndr a -> XTyVarBndr a

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

@@ -1,316 +0,0 @@
-{-# OPTIONS_GHC -Wno-implicit-prelude #-}
-
-module Language.Haskell.Brittany.Internal.ParseModule where
-
-import qualified Control.Monad as Monad
-import qualified Control.Monad.IO.Class as IO
-import qualified Control.Monad.Trans.Except as Except
-import qualified GHC
-import qualified GHC.ByteOrder
-import qualified GHC.Data.Bag
-import qualified GHC.Data.StringBuffer
-import qualified GHC.Driver.Session
-import qualified GHC.Parser.Header
-import qualified GHC.Platform
-import qualified GHC.Settings
-import qualified GHC.Types.SrcLoc
-import qualified GHC.Utils.Error
-import qualified GHC.Utils.Fingerprint
-import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint
-import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
-
--- | Parses a Haskell module. Although this nominally requires IO, it is
--- morally pure. It should have no observable effects.
-parseModule
-  :: IO.MonadIO io
-  => [String]
-  -> FilePath
-  -> (GHC.Driver.Session.DynFlags -> io (Either String a))
-  -> String
-  -> io (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
-parseModule arguments1 filePath checkDynFlags string = Except.runExceptT $ do
-  let
-    dynFlags1 = GHC.Driver.Session.gopt_set
-      -- It feels like this should be either @Sf_Ignore@ or @Sf_None@, but both
-      -- of those modes have trouble parsing safe imports (@import safe ...@).
-      -- Neither passing in @"-XUnsafe"@ as a command line argument nor having
-      -- @{-# LANGUAGE Unsafe #-}@ in the source file seem to help.
-      initialDynFlags
-        { GHC.Driver.Session.safeHaskell = GHC.Driver.Session.Sf_Unsafe
-        }
-      GHC.Driver.Session.Opt_KeepRawTokenStream
-  (dynFlags2, leftovers1, _) <-
-    GHC.Driver.Session.parseDynamicFlagsCmdLine dynFlags1
-      $ fmap GHC.Types.SrcLoc.noLoc arguments1
-  handleLeftovers leftovers1
-  let
-    stringBuffer = GHC.Data.StringBuffer.stringToStringBuffer string
-    arguments2 = GHC.Parser.Header.getOptions dynFlags2 stringBuffer filePath
-  (dynFlags3, leftovers2, _) <- GHC.Driver.Session.parseDynamicFilePragma
-    dynFlags2
-    arguments2
-  handleLeftovers leftovers2
-  dynFlagsResult <- Except.ExceptT $ checkDynFlags dynFlags3
-  let
-    parseResult =
-      ExactPrint.parseModuleFromStringInternal dynFlags3 filePath string
-  case parseResult of
-    Left errorMessages -> handleErrorMessages errorMessages
-    Right (anns, parsedSource) -> pure (anns, parsedSource, dynFlagsResult)
-
-handleLeftovers
-  :: Monad m => [GHC.Types.SrcLoc.Located String] -> Except.ExceptT String m ()
-handleLeftovers leftovers =
-  Monad.unless (null leftovers) . Except.throwE $ "leftovers: " <> show
-    (fmap GHC.Types.SrcLoc.unLoc leftovers)
-
-handleErrorMessages
-  :: Monad m => GHC.Utils.Error.ErrorMessages -> Except.ExceptT String m a
-handleErrorMessages =
-  Except.throwE . mappend "errorMessages: " . show . GHC.Data.Bag.bagToList
-
-initialDynFlags :: GHC.Driver.Session.DynFlags
-initialDynFlags = GHC.Driver.Session.defaultDynFlags initialSettings initialLlvmConfig
-
-initialSettings :: GHC.Driver.Session.Settings
-initialSettings = GHC.Driver.Session.Settings
-  { GHC.Driver.Session.sGhcNameVersion = initialGhcNameVersion
-  , GHC.Driver.Session.sFileSettings = initialFileSettings
-  , GHC.Driver.Session.sTargetPlatform = initialTargetPlatform
-  , GHC.Driver.Session.sToolSettings = initialToolSettings
-  , GHC.Driver.Session.sPlatformMisc = initialPlatformMisc
-  , GHC.Driver.Session.sPlatformConstants = initialPlatformConstants
-  , GHC.Driver.Session.sRawSettings = []
-  }
-
-initialFileSettings :: GHC.Driver.Session.FileSettings
-initialFileSettings = GHC.Driver.Session.FileSettings
-  { GHC.Driver.Session.fileSettings_ghciUsagePath = ""
-  , GHC.Driver.Session.fileSettings_ghcUsagePath = ""
-  , GHC.Driver.Session.fileSettings_globalPackageDatabase = ""
-  , GHC.Driver.Session.fileSettings_tmpDir = ""
-  , GHC.Driver.Session.fileSettings_toolDir = Nothing
-  , GHC.Driver.Session.fileSettings_topDir = ""
-  }
-
-initialGhcNameVersion :: GHC.Driver.Session.GhcNameVersion
-initialGhcNameVersion = GHC.Driver.Session.GhcNameVersion
-  { GHC.Driver.Session.ghcNameVersion_programName = ""
-  , GHC.Driver.Session.ghcNameVersion_projectVersion = ""
-  }
-
-initialPlatformMisc :: GHC.Driver.Session.PlatformMisc
-initialPlatformMisc = GHC.Driver.Session.PlatformMisc
-  { GHC.Driver.Session.platformMisc_ghcDebugged = False
-  , GHC.Driver.Session.platformMisc_ghcRTSWays = ""
-  , GHC.Driver.Session.platformMisc_ghcRtsWithLibdw = False
-  , GHC.Driver.Session.platformMisc_ghcThreaded = False
-  , GHC.Driver.Session.platformMisc_ghcWithInterpreter = False
-  , GHC.Driver.Session.platformMisc_ghcWithSMP = False
-  , GHC.Driver.Session.platformMisc_libFFI = False
-  , GHC.Driver.Session.platformMisc_llvmTarget = ""
-  , GHC.Driver.Session.platformMisc_targetPlatformString = ""
-  }
-
-initialLlvmConfig :: GHC.Driver.Session.LlvmConfig
-initialLlvmConfig = GHC.Driver.Session.LlvmConfig
-  { GHC.Driver.Session.llvmPasses = []
-  , GHC.Driver.Session.llvmTargets = []
-  }
-
-initialPlatformConstants :: GHC.Settings.PlatformConstants
-initialPlatformConstants = GHC.Settings.PlatformConstants
-  { GHC.Settings.pc_AP_STACK_SPLIM = 0
-  , GHC.Settings.pc_BITMAP_BITS_SHIFT = 0
-  , GHC.Settings.pc_BLOCK_SIZE = 0
-  , GHC.Settings.pc_BLOCKS_PER_MBLOCK = 0
-  , GHC.Settings.pc_CINT_SIZE = 0
-  , GHC.Settings.pc_CLONG_LONG_SIZE = 0
-  , GHC.Settings.pc_CLONG_SIZE = 0
-  , GHC.Settings.pc_CONTROL_GROUP_CONST_291 = 0
-  , GHC.Settings.pc_DYNAMIC_BY_DEFAULT = False
-  , GHC.Settings.pc_ILDV_CREATE_MASK = 0
-  , GHC.Settings.pc_ILDV_STATE_CREATE = 0
-  , GHC.Settings.pc_ILDV_STATE_USE = 0
-  , GHC.Settings.pc_LDV_SHIFT = 0
-  , GHC.Settings.pc_MAX_CHARLIKE = 0
-  , GHC.Settings.pc_MAX_Double_REG = 0
-  , GHC.Settings.pc_MAX_Float_REG = 0
-  , GHC.Settings.pc_MAX_INTLIKE = 0
-  , GHC.Settings.pc_MAX_Long_REG = 0
-  , GHC.Settings.pc_MAX_Real_Double_REG = 0
-  , GHC.Settings.pc_MAX_Real_Float_REG = 0
-  , GHC.Settings.pc_MAX_Real_Long_REG = 0
-  , GHC.Settings.pc_MAX_Real_Vanilla_REG = 0
-  , GHC.Settings.pc_MAX_Real_XMM_REG = 0
-  , GHC.Settings.pc_MAX_SPEC_AP_SIZE = 0
-  , GHC.Settings.pc_MAX_SPEC_SELECTEE_SIZE = 0
-  , GHC.Settings.pc_MAX_Vanilla_REG = 0
-  , GHC.Settings.pc_MAX_XMM_REG = 0
-  , GHC.Settings.pc_MIN_CHARLIKE = 0
-  , GHC.Settings.pc_MIN_INTLIKE = 0
-  , GHC.Settings.pc_MIN_PAYLOAD_SIZE = 0
-  , GHC.Settings.pc_MUT_ARR_PTRS_CARD_BITS = 0
-  , GHC.Settings.pc_OFFSET_bdescr_blocks = 0
-  , GHC.Settings.pc_OFFSET_bdescr_flags = 0
-  , GHC.Settings.pc_OFFSET_bdescr_free = 0
-  , GHC.Settings.pc_OFFSET_bdescr_start = 0
-  , GHC.Settings.pc_OFFSET_Capability_r = 0
-  , GHC.Settings.pc_OFFSET_CostCentreStack_mem_alloc = 0
-  , GHC.Settings.pc_OFFSET_CostCentreStack_scc_count = 0
-  , GHC.Settings.pc_OFFSET_StgArrBytes_bytes = 0
-  , GHC.Settings.pc_OFFSET_stgEagerBlackholeInfo = 0
-  , GHC.Settings.pc_OFFSET_StgEntCounter_allocd = 0
-  , GHC.Settings.pc_OFFSET_StgEntCounter_allocs = 0
-  , GHC.Settings.pc_OFFSET_StgEntCounter_entry_count = 0
-  , GHC.Settings.pc_OFFSET_StgEntCounter_link = 0
-  , GHC.Settings.pc_OFFSET_StgEntCounter_registeredp = 0
-  , GHC.Settings.pc_OFFSET_StgFunInfoExtraFwd_arity = 0
-  , GHC.Settings.pc_OFFSET_StgFunInfoExtraRev_arity = 0
-  , GHC.Settings.pc_OFFSET_stgGCEnter1 = 0
-  , GHC.Settings.pc_OFFSET_stgGCFun = 0
-  , GHC.Settings.pc_OFFSET_StgHeader_ccs = 0
-  , GHC.Settings.pc_OFFSET_StgHeader_ldvw = 0
-  , GHC.Settings.pc_OFFSET_StgMutArrPtrs_ptrs = 0
-  , GHC.Settings.pc_OFFSET_StgMutArrPtrs_size = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rCCCS = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rCurrentNursery = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rCurrentTSO = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rD1 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rD2 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rD3 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rD4 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rD5 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rD6 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rF1 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rF2 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rF3 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rF4 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rF5 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rF6 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rHp = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rHpAlloc = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rHpLim = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rL1 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rR1 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rR10 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rR2 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rR3 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rR4 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rR5 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rR6 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rR7 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rR8 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rR9 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rSp = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rSpLim = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rXMM1 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rXMM2 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rXMM3 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rXMM4 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rXMM5 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rXMM6 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rYMM1 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rYMM2 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rYMM3 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rYMM4 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rYMM5 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rYMM6 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rZMM1 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rZMM2 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rZMM3 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rZMM4 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rZMM5 = 0
-  , GHC.Settings.pc_OFFSET_StgRegTable_rZMM6 = 0
-  , GHC.Settings.pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0
-  , GHC.Settings.pc_OFFSET_StgStack_sp = 0
-  , GHC.Settings.pc_OFFSET_StgStack_stack = 0
-  , GHC.Settings.pc_OFFSET_StgTSO_alloc_limit = 0
-  , GHC.Settings.pc_OFFSET_StgTSO_cccs = 0
-  , GHC.Settings.pc_OFFSET_StgTSO_stackobj = 0
-  , GHC.Settings.pc_OFFSET_StgUpdateFrame_updatee = 0
-  , GHC.Settings.pc_PROF_HDR_SIZE = 0
-  , GHC.Settings.pc_REP_CostCentreStack_mem_alloc = 0
-  , GHC.Settings.pc_REP_CostCentreStack_scc_count = 0
-  , GHC.Settings.pc_REP_StgEntCounter_allocd = 0
-  , GHC.Settings.pc_REP_StgEntCounter_allocs = 0
-  , GHC.Settings.pc_REP_StgFunInfoExtraFwd_arity = 0
-  , GHC.Settings.pc_REP_StgFunInfoExtraRev_arity = 0
-  , GHC.Settings.pc_RESERVED_C_STACK_BYTES = 0
-  , GHC.Settings.pc_RESERVED_STACK_WORDS = 0
-  , GHC.Settings.pc_SIZEOF_CostCentreStack = 0
-  , GHC.Settings.pc_SIZEOF_StgArrBytes_NoHdr = 0
-  , GHC.Settings.pc_SIZEOF_StgFunInfoExtraRev = 0
-  , GHC.Settings.pc_SIZEOF_StgMutArrPtrs_NoHdr = 0
-  , GHC.Settings.pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 0
-  , GHC.Settings.pc_SIZEOF_StgSMPThunkHeader = 0
-  , GHC.Settings.pc_SIZEOF_StgUpdateFrame_NoHdr = 0
-  , GHC.Settings.pc_STD_HDR_SIZE = 0
-  , GHC.Settings.pc_TAG_BITS = 0
-  , GHC.Settings.pc_TICKY_BIN_COUNT = 0
-  , GHC.Settings.pc_WORD_SIZE = 0
-  }
-
-initialPlatformMini :: GHC.Settings.PlatformMini
-initialPlatformMini = GHC.Settings.PlatformMini
-  { GHC.Settings.platformMini_arch = GHC.Platform.ArchX86_64
-  , GHC.Settings.platformMini_os = GHC.Platform.OSLinux
-  }
-
-initialTargetPlatform :: GHC.Settings.Platform
-initialTargetPlatform = GHC.Settings.Platform
-  { GHC.Settings.platformByteOrder = GHC.ByteOrder.LittleEndian
-  , GHC.Settings.platformHasGnuNonexecStack = False
-  , GHC.Settings.platformHasIdentDirective = False
-  , GHC.Settings.platformHasSubsectionsViaSymbols = False
-  , GHC.Settings.platformIsCrossCompiling = False
-  , GHC.Settings.platformLeadingUnderscore = False
-  , GHC.Settings.platformMini = initialPlatformMini
-  , GHC.Settings.platformTablesNextToCode = False
-  , GHC.Settings.platformUnregisterised = False
-  , GHC.Settings.platformWordSize = GHC.Platform.PW8
-  }
-
-initialToolSettings :: GHC.Settings.ToolSettings
-initialToolSettings = GHC.Settings.ToolSettings
-  { GHC.Settings.toolSettings_ccSupportsNoPie = False
-  , GHC.Settings.toolSettings_extraGccViaCFlags = []
-  , GHC.Settings.toolSettings_ldIsGnuLd = False
-  , GHC.Settings.toolSettings_ldSupportsBuildId = False
-  , GHC.Settings.toolSettings_ldSupportsCompactUnwind = False
-  , GHC.Settings.toolSettings_ldSupportsFilelist = False
-  , GHC.Settings.toolSettings_opt_a = []
-  , GHC.Settings.toolSettings_opt_c = []
-  , GHC.Settings.toolSettings_opt_cxx = []
-  , GHC.Settings.toolSettings_opt_F = []
-  , GHC.Settings.toolSettings_opt_i = []
-  , GHC.Settings.toolSettings_opt_l = []
-  , GHC.Settings.toolSettings_opt_L = []
-  , GHC.Settings.toolSettings_opt_lc = []
-  , GHC.Settings.toolSettings_opt_lcc = []
-  , GHC.Settings.toolSettings_opt_lm = []
-  , GHC.Settings.toolSettings_opt_lo = []
-  , GHC.Settings.toolSettings_opt_P = []
-  , GHC.Settings.toolSettings_opt_P_fingerprint =
-    GHC.Utils.Fingerprint.fingerprint0
-  , GHC.Settings.toolSettings_opt_windres = []
-  , GHC.Settings.toolSettings_pgm_a = ("", [])
-  , GHC.Settings.toolSettings_pgm_ar = ""
-  , GHC.Settings.toolSettings_pgm_c = ""
-  , GHC.Settings.toolSettings_pgm_dll = ("", [])
-  , GHC.Settings.toolSettings_pgm_F = ""
-  , GHC.Settings.toolSettings_pgm_i = ""
-  , GHC.Settings.toolSettings_pgm_install_name_tool = ""
-  , GHC.Settings.toolSettings_pgm_l = ("", [])
-  , GHC.Settings.toolSettings_pgm_L = ""
-  , GHC.Settings.toolSettings_pgm_lc = ("", [])
-  , GHC.Settings.toolSettings_pgm_lcc = ("", [])
-  , GHC.Settings.toolSettings_pgm_libtool = ""
-  , GHC.Settings.toolSettings_pgm_lm = ("", [])
-  , GHC.Settings.toolSettings_pgm_lo = ("", [])
-  , GHC.Settings.toolSettings_pgm_otool = ""
-  , GHC.Settings.toolSettings_pgm_P = ("", [])
-  , GHC.Settings.toolSettings_pgm_ranlib = ""
-  , GHC.Settings.toolSettings_pgm_T = ""
-  , GHC.Settings.toolSettings_pgm_windres = ""
-  }

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

@@ -1,5 +1,8 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 module Language.Haskell.Brittany.Internal.Prelude
   ( module E
+  , module Language.Haskell.Brittany.Internal.Prelude
   ) where
 
 import Control.Applicative as E (Alternative(..), Applicative(..))
@@ -75,8 +78,6 @@ import Data.List as E
   , mapAccumR
   , maximum
   , minimum
-  , notElem
-  , nub
   , null
   , partition
   , repeat
@@ -110,7 +111,7 @@ import Data.Monoid as E
 import Data.Ord as E (Down(..), Ordering(..), comparing)
 import Data.Proxy as E (Proxy(..))
 import Data.Ratio as E ((%), Ratio, Rational, denominator, numerator)
-import Data.Semigroup as E ((<>), Semigroup(..))
+import Data.Semigroup as E ((<>), Semigroup(..), Last(Last))
 import Data.Sequence as E (Seq)
 import Data.Set as E (Set)
 import Data.String as E (String)
@@ -135,6 +136,7 @@ import Foreign.ForeignPtr as E (ForeignPtr)
 import Foreign.Storable as E (Storable)
 import GHC.Exts as E (Constraint)
 import GHC.Hs.Extension as E (GhcPs)
+import GHC.Stack as E (HasCallStack)
 import GHC.Types.Name.Reader as E (RdrName)
 import Prelude as E
   ( ($)
@@ -143,7 +145,6 @@ import Prelude as E
   , (++)
   , (.)
   , (<$>)
-  , Bounded(..)
   , Double
   , Enum(..)
   , Eq(..)
@@ -163,10 +164,8 @@ import Prelude as E
   , and
   , any
   , const
-  , curry
   , error
   , flip
-  , foldl
   , foldr
   , foldr1
   , fromIntegral
@@ -192,3 +191,94 @@ import Prelude as E
   )
 import System.IO as E (IO, hFlush, stdout)
 import Text.Read as E (readMaybe)
+
+import qualified Data.Strict.Maybe as Strict
+import Control.DeepSeq (NFData, force)
+import System.IO (hPutStrLn, stderr, hPutStr)
+import qualified Data.Data
+import           GHC.Types.SrcLoc               ( RealSrcLoc )
+import qualified GHC.Utils.Misc
+import qualified Data.Generics.Uniplate.Direct as Uniplate
+import qualified Data.Sequence as Seq
+
+
+
+instance Applicative Strict.Maybe where
+  pure = Strict.Just
+  Strict.Just f <*> Strict.Just x = Strict.Just (f x)
+  _ <*> _ = Strict.Nothing
+
+instance Monad Strict.Maybe where
+  Strict.Nothing >>= _ = Strict.Nothing
+  Strict.Just x >>= f = f x
+
+instance Alternative Strict.Maybe where
+  empty = Strict.Nothing
+  x <|> Strict.Nothing = x
+  _ <|> x = x
+
+traceFunctionWith
+  :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b)
+traceFunctionWith name s1 s2 f x = trace traceStr y
+ where
+  y = f x
+  traceStr = name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y
+
+(<&!>) :: Monad m => m a -> (a -> b) -> m b
+(<&!>) = flip (<$!>)
+
+putStrErrLn :: String -> IO ()
+putStrErrLn s = hPutStrLn stderr s
+
+putStrErr :: String -> IO ()
+putStrErr s = hPutStr stderr s
+
+printErr :: Show a => a -> IO ()
+printErr = putStrErrLn . show
+
+errorIf :: Bool -> a -> a
+errorIf False = id
+errorIf True = error "errorIf"
+
+errorIfNote :: Maybe String -> a -> a
+errorIfNote Nothing = id
+errorIfNote (Just x) = error x
+
+(<&>) :: Functor f => f a -> (a -> b) -> f b
+(<&>) = flip fmap
+infixl 4 <&>
+
+(.>) :: (a -> b) -> (b -> c) -> (a -> c)
+f .> g = g . f
+infixl 9 .>
+
+evaluateDeep :: NFData a => a -> IO a
+evaluateDeep = evaluate . force
+
+instance Data.Data.Data RealSrcLoc where
+  -- don't traverse?
+  toConstr _ = GHC.Utils.Misc.abstractConstr "RealSrcLoc"
+  gunfold _ _ = error "gunfold"
+  dataTypeOf _ = GHC.Utils.Misc.mkNoRepType "RealSrcLoc"
+
+-- TODO: move to uniplate upstream?
+-- aka `transform`
+transformUp :: Uniplate.Uniplate on => (on -> on) -> (on -> on)
+transformUp f = g where g = f . Uniplate.descend g
+_transformDown :: Uniplate.Uniplate on => (on -> on) -> (on -> on)
+_transformDown f = g where g = Uniplate.descend g . f
+transformDownMay :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on)
+transformDownMay f = g where g x = maybe x (Uniplate.descend g) $ f x
+_transformDownRec :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on)
+_transformDownRec f = g where g x = maybe (Uniplate.descend g x) g $ f x
+
+-- i should really put that into multistate..
+mModify :: MonadMultiState s m => (s -> s) -> m ()
+mModify f = mGet >>= mSet . f
+
+tellDebugMess :: MonadMultiWriter (Seq String) m => String -> m ()
+tellDebugMess s = mTell $ Seq.singleton s
+
+tellDebugMessShow
+  :: forall a m . (MonadMultiWriter (Seq String) m, Show a) => a -> m ()
+tellDebugMessShow = tellDebugMess . show

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

@@ -1,66 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Language.Haskell.Brittany.Internal.PreludeUtils where
-
-import Control.Applicative
-import Control.DeepSeq (NFData, force)
-import Control.Exception.Base (evaluate)
-import Control.Monad
-import qualified Data.Strict.Maybe as Strict
-import Debug.Trace
-import Prelude
-import System.IO
-
-
-
-instance Applicative Strict.Maybe where
-  pure = Strict.Just
-  Strict.Just f <*> Strict.Just x = Strict.Just (f x)
-  _ <*> _ = Strict.Nothing
-
-instance Monad Strict.Maybe where
-  Strict.Nothing >>= _ = Strict.Nothing
-  Strict.Just x >>= f = f x
-
-instance Alternative Strict.Maybe where
-  empty = Strict.Nothing
-  x <|> Strict.Nothing = x
-  _ <|> x = x
-
-traceFunctionWith
-  :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b)
-traceFunctionWith name s1 s2 f x = trace traceStr y
- where
-  y = f x
-  traceStr = name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y
-
-(<&!>) :: Monad m => m a -> (a -> b) -> m b
-(<&!>) = flip (<$!>)
-
-putStrErrLn :: String -> IO ()
-putStrErrLn s = hPutStrLn stderr s
-
-putStrErr :: String -> IO ()
-putStrErr s = hPutStr stderr s
-
-printErr :: Show a => a -> IO ()
-printErr = putStrErrLn . show
-
-errorIf :: Bool -> a -> a
-errorIf False = id
-errorIf True = error "errorIf"
-
-errorIfNote :: Maybe String -> a -> a
-errorIfNote Nothing = id
-errorIfNote (Just x) = error x
-
-(<&>) :: Functor f => f a -> (a -> b) -> f b
-(<&>) = flip fmap
-infixl 4 <&>
-
-(.>) :: (a -> b) -> (b -> c) -> (a -> c)
-f .> g = g . f
-infixl 9 .>
-
-evaluateDeep :: NFData a => a -> IO a
-evaluateDeep = evaluate . force

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

@@ -0,0 +1,346 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Language.Haskell.Brittany.Internal.S1_Parsing
+  ( parseModule
+  , parseModuleFromString
+  )
+where
+
+import           Language.Haskell.Brittany.Internal.Prelude
+
+import qualified Control.Monad
+import qualified Control.Monad.Trans.Except    as Except
+import qualified GHC                     hiding ( parseModule )
+import qualified GHC.ByteOrder
+import qualified GHC.Data.Bag
+import qualified GHC.Data.StringBuffer
+import qualified GHC.Driver.Session
+import qualified GHC.Parser.Header
+import qualified GHC.Platform
+import qualified GHC.Settings
+import qualified GHC.Types.SrcLoc
+import qualified GHC.Utils.Error
+import qualified GHC.Utils.Fingerprint
+import qualified Language.Haskell.GHC.ExactPrint.Parsers
+                                               as ExactPrint
+import qualified System.IO
+
+
+
+-- TODO why are redirecting to parseModuleFromString here?
+parseModule
+  :: [String]
+  -> System.IO.FilePath
+  -> (GHC.DynFlags -> IO (Either String a))
+  -> IO (Either String (GHC.ParsedSource, a))
+parseModule args fp dynCheck = do
+  str <- System.IO.readFile fp
+  parseModuleFromString args fp dynCheck str
+
+-- | Parses a Haskell module. Although this nominally requires IO, it is
+-- morally pure. It should have no observable effects.
+parseModuleFromString
+  :: [String]
+  -> System.IO.FilePath
+  -> (GHC.DynFlags -> IO (Either String a))
+  -> String
+  -> IO (Either String (GHC.ParsedSource, a))
+parseModuleFromString arguments1 filePath checkDynFlags string =
+  Except.runExceptT $ do
+    let dynFlags1 = GHC.Driver.Session.gopt_set
+          -- It feels like this should be either @Sf_Ignore@ or @Sf_None@, but both
+          -- of those modes have trouble parsing safe imports (@import safe ...@).
+          -- Neither passing in @"-XUnsafe"@ as a command line argument nor having
+          -- @{-# LANGUAGE Unsafe #-}@ in the source file seem to help.
+          initialDynFlags { GHC.Driver.Session.safeHaskell = GHC.Sf_Unsafe }
+          GHC.Driver.Session.Opt_KeepRawTokenStream
+    (dynFlags2, leftovers1, _) <-
+      GHC.Driver.Session.parseDynamicFlagsCmdLine dynFlags1
+        $ fmap GHC.Types.SrcLoc.noLoc arguments1
+    handleLeftovers leftovers1
+    let stringBuffer = GHC.Data.StringBuffer.stringToStringBuffer string
+        arguments2 =
+          GHC.Parser.Header.getOptions dynFlags2 stringBuffer filePath
+    (dynFlags3, leftovers2, _) <- GHC.Driver.Session.parseDynamicFilePragma
+      dynFlags2
+      arguments2
+    handleLeftovers leftovers2
+    dynFlagsResult <- Except.ExceptT $ checkDynFlags dynFlags3
+    let parseResult =
+          ExactPrint.parseModuleFromStringInternal dynFlags3 filePath string
+    case parseResult of
+      Left  errorMessages -> handleErrorMessages errorMessages
+      -- Right parsedMod -> case ExactPrint.makeDeltaAst' parsedMod of
+      --   res -> pure (res, dynFlagsResult)
+      -- Right (L l (GHC.HsModule ann lay name xprt imp decls depr hdr)) ->
+      --   case ExactPrint.runTransform (ExactPrint.balanceCommentsList decls) of
+      --     (decls', _, _) ->
+      --       pure
+      --         ( L l (GHC.HsModule ann lay name xprt imp decls' depr hdr)
+      --         , dynFlagsResult
+      --         )
+      Right res           -> pure (res, dynFlagsResult)
+
+handleLeftovers
+  :: Monad m => [GHC.Types.SrcLoc.Located String] -> Except.ExceptT String m ()
+handleLeftovers leftovers =
+  Control.Monad.unless (null leftovers) . Except.throwE $ "leftovers: " <> show
+    (fmap GHC.Types.SrcLoc.unLoc leftovers)
+
+handleErrorMessages
+  :: Monad m => GHC.Utils.Error.ErrorMessages -> Except.ExceptT String m a
+handleErrorMessages =
+  Except.throwE . mappend "errorMessages: " . show . GHC.Data.Bag.bagToList
+
+initialDynFlags :: GHC.Driver.Session.DynFlags
+initialDynFlags =
+  GHC.Driver.Session.defaultDynFlags initialSettings initialLlvmConfig
+
+initialSettings :: GHC.Driver.Session.Settings
+initialSettings = GHC.Driver.Session.Settings
+  { GHC.Driver.Session.sGhcNameVersion = initialGhcNameVersion
+  , GHC.Driver.Session.sFileSettings   = initialFileSettings
+  , GHC.Driver.Session.sTargetPlatform = initialTargetPlatform
+  , GHC.Driver.Session.sToolSettings   = initialToolSettings
+  , GHC.Driver.Session.sPlatformMisc   = initialPlatformMisc
+  , GHC.Driver.Session.sRawSettings    = []
+  }
+
+initialFileSettings :: GHC.Driver.Session.FileSettings
+initialFileSettings = GHC.Driver.Session.FileSettings
+  { GHC.Driver.Session.fileSettings_ghciUsagePath         = ""
+  , GHC.Driver.Session.fileSettings_ghcUsagePath          = ""
+  , GHC.Driver.Session.fileSettings_globalPackageDatabase = ""
+  , GHC.Driver.Session.fileSettings_tmpDir                = ""
+  , GHC.Driver.Session.fileSettings_toolDir               = Nothing
+  , GHC.Driver.Session.fileSettings_topDir                = ""
+  }
+
+initialGhcNameVersion :: GHC.Driver.Session.GhcNameVersion
+initialGhcNameVersion = GHC.Driver.Session.GhcNameVersion
+  { GHC.Driver.Session.ghcNameVersion_programName    = ""
+  , GHC.Driver.Session.ghcNameVersion_projectVersion = ""
+  }
+
+initialPlatformMisc :: GHC.Driver.Session.PlatformMisc
+initialPlatformMisc = GHC.Driver.Session.PlatformMisc
+  { GHC.Driver.Session.platformMisc_ghcRTSWays           = ""
+  , GHC.Driver.Session.platformMisc_ghcRtsWithLibdw      = False
+  , GHC.Driver.Session.platformMisc_ghcWithInterpreter   = False
+  , GHC.Driver.Session.platformMisc_ghcWithSMP           = False
+  , GHC.Driver.Session.platformMisc_libFFI               = False
+  , GHC.Driver.Session.platformMisc_llvmTarget           = ""
+  , GHC.Driver.Session.platformMisc_targetPlatformString = ""
+  }
+
+initialLlvmConfig :: GHC.Driver.Session.LlvmConfig
+initialLlvmConfig = GHC.Driver.Session.LlvmConfig
+  { GHC.Driver.Session.llvmPasses  = []
+  , GHC.Driver.Session.llvmTargets = []
+  }
+
+_initialPlatformConstants :: GHC.Platform.PlatformConstants
+_initialPlatformConstants = GHC.Platform.PlatformConstants
+  { GHC.Platform.pc_AP_STACK_SPLIM                     = 0
+  , GHC.Platform.pc_BITMAP_BITS_SHIFT                  = 0
+  , GHC.Platform.pc_BLOCK_SIZE                         = 0
+  , GHC.Platform.pc_BLOCKS_PER_MBLOCK                  = 0
+  , GHC.Platform.pc_CINT_SIZE                          = 0
+  , GHC.Platform.pc_CLONG_LONG_SIZE                    = 0
+  , GHC.Platform.pc_CLONG_SIZE                         = 0
+  , GHC.Platform.pc_CONTROL_GROUP_CONST_291            = 0
+  , GHC.Platform.pc_ILDV_CREATE_MASK                   = 0
+  , GHC.Platform.pc_ILDV_STATE_CREATE                  = 0
+  , GHC.Platform.pc_ILDV_STATE_USE                     = 0
+  , GHC.Platform.pc_LDV_SHIFT                          = 0
+  , GHC.Platform.pc_MAX_CHARLIKE                       = 0
+  , GHC.Platform.pc_MAX_Double_REG                     = 0
+  , GHC.Platform.pc_MAX_Float_REG                      = 0
+  , GHC.Platform.pc_MAX_INTLIKE                        = 0
+  , GHC.Platform.pc_MAX_Long_REG                       = 0
+  , GHC.Platform.pc_MAX_Real_Double_REG                = 0
+  , GHC.Platform.pc_MAX_Real_Float_REG                 = 0
+  , GHC.Platform.pc_MAX_Real_Long_REG                  = 0
+  , GHC.Platform.pc_MAX_Real_Vanilla_REG               = 0
+  , GHC.Platform.pc_MAX_Real_XMM_REG                   = 0
+  , GHC.Platform.pc_MAX_SPEC_AP_SIZE                   = 0
+  , GHC.Platform.pc_MAX_SPEC_SELECTEE_SIZE             = 0
+  , GHC.Platform.pc_MAX_Vanilla_REG                    = 0
+  , GHC.Platform.pc_MAX_XMM_REG                        = 0
+  , GHC.Platform.pc_MIN_CHARLIKE                       = 0
+  , GHC.Platform.pc_MIN_INTLIKE                        = 0
+  , GHC.Platform.pc_MIN_PAYLOAD_SIZE                   = 0
+  , GHC.Platform.pc_MUT_ARR_PTRS_CARD_BITS             = 0
+  , GHC.Platform.pc_OFFSET_bdescr_blocks               = 0
+  , GHC.Platform.pc_OFFSET_bdescr_flags                = 0
+  , GHC.Platform.pc_OFFSET_bdescr_free                 = 0
+  , GHC.Platform.pc_OFFSET_bdescr_start                = 0
+  , GHC.Platform.pc_OFFSET_Capability_r                = 0
+  , GHC.Platform.pc_OFFSET_CostCentreStack_mem_alloc   = 0
+  , GHC.Platform.pc_OFFSET_CostCentreStack_scc_count   = 0
+  , GHC.Platform.pc_OFFSET_StgArrBytes_bytes           = 0
+  , GHC.Platform.pc_OFFSET_stgEagerBlackholeInfo       = 0
+  , GHC.Platform.pc_OFFSET_StgEntCounter_allocd        = 0
+  , GHC.Platform.pc_OFFSET_StgEntCounter_allocs        = 0
+  , GHC.Platform.pc_OFFSET_StgEntCounter_entry_count   = 0
+  , GHC.Platform.pc_OFFSET_StgEntCounter_link          = 0
+  , GHC.Platform.pc_OFFSET_StgEntCounter_registeredp   = 0
+  , GHC.Platform.pc_OFFSET_StgFunInfoExtraFwd_arity    = 0
+  , GHC.Platform.pc_OFFSET_StgFunInfoExtraRev_arity    = 0
+  , GHC.Platform.pc_OFFSET_stgGCEnter1                 = 0
+  , GHC.Platform.pc_OFFSET_stgGCFun                    = 0
+  , GHC.Platform.pc_OFFSET_StgHeader_ccs               = 0
+  , GHC.Platform.pc_OFFSET_StgHeader_ldvw              = 0
+  , GHC.Platform.pc_OFFSET_StgMutArrPtrs_ptrs          = 0
+  , GHC.Platform.pc_OFFSET_StgMutArrPtrs_size          = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rCCCS           = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rCurrentNursery = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rCurrentTSO     = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rD1             = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rD2             = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rD3             = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rD4             = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rD5             = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rD6             = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rF1             = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rF2             = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rF3             = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rF4             = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rF5             = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rF6             = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rHp             = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rHpAlloc        = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rHpLim          = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rL1             = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rR1             = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rR10            = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rR2             = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rR3             = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rR4             = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rR5             = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rR6             = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rR7             = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rR8             = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rR9             = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rSp             = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rSpLim          = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rXMM1           = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rXMM2           = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rXMM3           = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rXMM4           = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rXMM5           = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rXMM6           = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rYMM1           = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rYMM2           = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rYMM3           = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rYMM4           = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rYMM5           = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rYMM6           = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rZMM1           = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rZMM2           = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rZMM3           = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rZMM4           = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rZMM5           = 0
+  , GHC.Platform.pc_OFFSET_StgRegTable_rZMM6           = 0
+  , GHC.Platform.pc_OFFSET_StgSmallMutArrPtrs_ptrs     = 0
+  , GHC.Platform.pc_OFFSET_StgStack_sp                 = 0
+  , GHC.Platform.pc_OFFSET_StgStack_stack              = 0
+  , GHC.Platform.pc_OFFSET_StgTSO_alloc_limit          = 0
+  , GHC.Platform.pc_OFFSET_StgTSO_cccs                 = 0
+  , GHC.Platform.pc_OFFSET_StgTSO_stackobj             = 0
+  , GHC.Platform.pc_OFFSET_StgUpdateFrame_updatee      = 0
+  , GHC.Platform.pc_PROF_HDR_SIZE                      = 0
+  , GHC.Platform.pc_REP_CostCentreStack_mem_alloc      = 0
+  , GHC.Platform.pc_REP_CostCentreStack_scc_count      = 0
+  , GHC.Platform.pc_REP_StgEntCounter_allocd           = 0
+  , GHC.Platform.pc_REP_StgEntCounter_allocs           = 0
+  , GHC.Platform.pc_REP_StgFunInfoExtraFwd_arity       = 0
+  , GHC.Platform.pc_REP_StgFunInfoExtraRev_arity       = 0
+  , GHC.Platform.pc_RESERVED_C_STACK_BYTES             = 0
+  , GHC.Platform.pc_RESERVED_STACK_WORDS               = 0
+  , GHC.Platform.pc_SIZEOF_CostCentreStack             = 0
+  , GHC.Platform.pc_SIZEOF_StgArrBytes_NoHdr           = 0
+  , GHC.Platform.pc_SIZEOF_StgFunInfoExtraRev          = 0
+  , GHC.Platform.pc_SIZEOF_StgMutArrPtrs_NoHdr         = 0
+  , GHC.Platform.pc_SIZEOF_StgSmallMutArrPtrs_NoHdr    = 0
+  , GHC.Platform.pc_SIZEOF_StgSMPThunkHeader           = 0
+  , GHC.Platform.pc_SIZEOF_StgUpdateFrame_NoHdr        = 0
+  , GHC.Platform.pc_STD_HDR_SIZE                       = 0
+  , GHC.Platform.pc_TAG_BITS                           = 0
+  , GHC.Platform.pc_TICKY_BIN_COUNT                    = 0
+  , GHC.Platform.pc_WORD_SIZE                          = 0
+  }
+
+-- initialPlatformMini :: GHC.Settings.PlatformMini
+-- initialPlatformMini = GHC.Settings.PlatformMini
+--   { GHC.Settings.platformMini_arch = GHC.Platform.ArchX86_64
+--   , GHC.Settings.platformMini_os = GHC.Platform.OSLinux
+--   }
+
+initialTargetPlatform :: GHC.Settings.Platform
+initialTargetPlatform = GHC.Settings.Platform
+  { GHC.Settings.platformArchOS                   = initialArchOS
+  , GHC.Settings.platformByteOrder                = GHC.ByteOrder.LittleEndian
+  , GHC.Settings.platformHasGnuNonexecStack       = False
+  , GHC.Settings.platformHasIdentDirective        = False
+  , GHC.Settings.platformHasSubsectionsViaSymbols = False
+  , GHC.Settings.platformIsCrossCompiling         = False
+  , GHC.Settings.platformLeadingUnderscore        = False
+  -- , GHC.Settings.platformMini = initialPlatformMini
+  , GHC.Settings.platformTablesNextToCode         = False
+  , GHC.Settings.platformUnregisterised           = False
+  , GHC.Settings.platformWordSize                 = GHC.Platform.PW8
+  , GHC.Settings.platform_constants               = Nothing
+  }
+
+initialArchOS :: GHC.Platform.ArchOS
+initialArchOS = GHC.Platform.ArchOS
+  { GHC.Platform.archOS_arch = GHC.Platform.ArchUnknown -- why do we need to specify these?
+  , GHC.Platform.archOS_OS   = GHC.Platform.OSUnknown -- why do we need to specify these?
+  }
+
+initialToolSettings :: GHC.Settings.ToolSettings
+initialToolSettings = GHC.Settings.ToolSettings
+  { GHC.Settings.toolSettings_ccSupportsNoPie         = False
+  , GHC.Settings.toolSettings_extraGccViaCFlags       = []
+  , GHC.Settings.toolSettings_ldIsGnuLd               = False
+  , GHC.Settings.toolSettings_ldSupportsBuildId       = False
+  , GHC.Settings.toolSettings_ldSupportsCompactUnwind = False
+  , GHC.Settings.toolSettings_ldSupportsFilelist      = False
+  , GHC.Settings.toolSettings_opt_a                   = []
+  , GHC.Settings.toolSettings_opt_c                   = []
+  , GHC.Settings.toolSettings_opt_cxx                 = []
+  , GHC.Settings.toolSettings_opt_F                   = []
+  , GHC.Settings.toolSettings_opt_i                   = []
+  , GHC.Settings.toolSettings_opt_l                   = []
+  , GHC.Settings.toolSettings_opt_L                   = []
+  , GHC.Settings.toolSettings_opt_lc                  = []
+  , GHC.Settings.toolSettings_opt_lcc                 = []
+  , GHC.Settings.toolSettings_opt_lm                  = []
+  , GHC.Settings.toolSettings_opt_lo                  = []
+  , GHC.Settings.toolSettings_opt_P                   = []
+  , GHC.Settings.toolSettings_opt_P_fingerprint       =
+    GHC.Utils.Fingerprint.fingerprint0
+  , GHC.Settings.toolSettings_opt_windres             = []
+  , GHC.Settings.toolSettings_pgm_a                   = ("", [])
+  , GHC.Settings.toolSettings_pgm_ar                  = ""
+  , GHC.Settings.toolSettings_pgm_c                   = ""
+  , GHC.Settings.toolSettings_pgm_dll                 = ("", [])
+  , GHC.Settings.toolSettings_pgm_F                   = ""
+  , GHC.Settings.toolSettings_pgm_i                   = ""
+  , GHC.Settings.toolSettings_pgm_install_name_tool   = ""
+  , GHC.Settings.toolSettings_pgm_l                   = ("", [])
+  , GHC.Settings.toolSettings_pgm_L                   = ""
+  , GHC.Settings.toolSettings_pgm_lc                  = ("", [])
+  , GHC.Settings.toolSettings_pgm_lcc                 = ("", [])
+  , GHC.Settings.toolSettings_pgm_libtool             = ""
+  , GHC.Settings.toolSettings_pgm_lm                  = ("", [])
+  , GHC.Settings.toolSettings_pgm_lo                  = ("", [])
+  , GHC.Settings.toolSettings_pgm_otool               = ""
+  , GHC.Settings.toolSettings_pgm_P                   = ("", [])
+  , GHC.Settings.toolSettings_pgm_ranlib              = ""
+  , GHC.Settings.toolSettings_pgm_T                   = ""
+  , GHC.Settings.toolSettings_pgm_windres             = ""
+  }
+
+

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

@@ -0,0 +1,380 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+-- TODO92
+
+module Language.Haskell.Brittany.Internal.S2_SplitModule
+  ( splitModule
+  )
+where
+
+
+
+import           Language.Haskell.Brittany.Internal.Prelude
+
+import qualified Data.Generics                 as SYB
+import qualified GHC
+import           GHC                            ( AddEpAnn(AddEpAnn)
+                                                , Anchor(Anchor)
+                                                , EpAnn(EpAnn, EpAnnNotUsed)
+                                                , EpAnnComments
+                                                  ( EpaComments
+                                                  , EpaCommentsBalanced
+                                                  )
+                                                , EpaComment(EpaComment)
+                                                , EpaCommentTok
+                                                  ( EpaBlockComment
+                                                  , EpaDocCommentNamed
+                                                  , EpaDocCommentNext
+                                                  , EpaDocCommentPrev
+                                                  , EpaDocOptions
+                                                  , EpaDocSection
+                                                  , EpaEofComment
+                                                  , EpaLineComment
+                                                  )
+                                                , EpaLocation(EpaSpan)
+                                                , GenLocated(L)
+                                                , HsModule(HsModule)
+                                                , LEpaComment
+                                                , LHsDecl
+                                                , LImportDecl
+                                                , SrcSpan
+                                                  ( RealSrcSpan
+                                                  , UnhelpfulSpan
+                                                  )
+                                                , SrcSpanAnn'(SrcSpanAnn)
+                                                , anchor
+                                                , ideclName
+                                                , moduleNameString
+                                                , srcLocCol
+                                                , srcLocLine
+                                                , unLoc
+                                                )
+import qualified GHC.OldList                   as List
+import           GHC.Parser.Annotation          ( DeltaPos
+                                                  ( DifferentLine
+                                                  , SameLine
+                                                  )
+                                                , EpaCommentTok(EpaEofComment)
+                                                )
+import           GHC.Types.SrcLoc               ( realSrcSpanEnd )
+import qualified Language.Haskell.GHC.ExactPrint.Types
+                                               as ExactPrint
+import qualified Language.Haskell.GHC.ExactPrint.Utils
+                                               as ExactPrint
+import           Safe                           ( maximumMay )
+
+import           Language.Haskell.Brittany.Internal.Components.BriDoc
+import           Language.Haskell.Brittany.Internal.ToBriDoc.Module
+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
+  enrichComms spanAfterDecls finalComments
+
+
+enrichComms
+  :: ExactPrint.Pos -> [LEpaComment] -> FinalList ModuleElement ExactPrint.Pos
+enrichComms lastSpanEnd = \case
+  [] -> pure lastSpanEnd
+  (L (Anchor span _) (EpaComment EpaEofComment _) : commRest) -> do
+    finalYield $ MEWhitespace $ case ExactPrint.ss2delta lastSpanEnd span of -- TODO92 move this (l-1) bit into utility function
+      SameLine i        -> SameLine i
+      DifferentLine l c -> DifferentLine (l - 1) c
+    enrichComms (ExactPrint.ss2posEnd span) commRest
+  (L (Anchor span _) (EpaComment comm _) : commRest) -> do
+    case ExactPrint.ss2delta lastSpanEnd span of
+      SameLine i -> do
+        finalYield $ MEComment (i, comm)
+      DifferentLine l c -> do
+        finalYield $ MEWhitespace $ DifferentLine (l - 1) c
+        finalYield $ MEComment (0, comm)
+    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) ->
+    case dAnn of
+      EpAnn dAnchor items (EpaComments dComments) -> do
+        let
+          withoutComments =
+            (L (SrcSpanAnn (EpAnn dAnchor items (EpaComments [])) 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
+        case ExactPrint.ss2delta lastSpanEnd span of
+          SameLine{} -> pure ()
+          DifferentLine n _ ->
+            finalYield $ MEWhitespace $ DifferentLine (n - 1) 1
+        let (afterComms, span2) = finalToList $ enrichComms fixedSpanEnd (reverse dComments)
+        let (immediate, later) = List.span (\case
+              MEComment{} -> True
+              _ -> False
+              ) afterComms
+        finalYield $ MEDecl withoutComments [ comm | MEComment comm <- immediate ]
+        later `forM_` finalYield
+        enrichDecls span2 declRest
+      EpAnn _anchor _items (EpaCommentsBalanced{}) ->
+        error "EpaCommentsBalanced"
+      EpAnnNotUsed -> error "EpAnnNotUsed"
+  (L (SrcSpanAnn _ann (GHC.UnhelpfulSpan{})) _decl : _declRest) ->
+    error "UnhelpfulSpan"
+
+
+-- module head pretty-printing
+
+data ImportLine
+  = EmptyLines Int
+  | SamelineComment (Int, EpaCommentTok)
+  | NewlineComment  (Int, EpaCommentTok) -- indentation and comment
+  | ImportStatement ImportStatementRecord
+
+instance Show ImportLine where
+  show = \case
+    EmptyLines n      -> "EmptyLines " ++ show n
+    SamelineComment{} -> "SamelineComment"
+    NewlineComment{}  -> "NewlineComment"
+    ImportStatement r ->
+      "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
+        (length $ commentsAfter r)
+
+data ImportStatementRecord = ImportStatementRecord
+  { commentsBefore   :: [(Int, EpaCommentTok)]
+  , importStatement  :: LImportDecl GhcPs
+  , commentsSameline :: [(Int, EpaCommentTok)]
+  , commentsAfter    :: [(Int, EpaCommentTok)]
+  }
+
+instance Show ImportStatementRecord where
+  show r =
+    "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
+      (length $ commentsAfter r)
+
+
+transformToImportLine
+  :: ExactPrint.Pos
+  -> [LImportDecl GhcPs]
+  -> FinalList ImportLine ExactPrint.Pos
+transformToImportLine startPos is =
+  let
+    flattenComms
+      :: [LEpaComment] -> ExactPrint.Pos -> FinalList ImportLine ExactPrint.Pos
+    flattenComms = \case
+      [] -> finalPure
+      (L (Anchor span _) (EpaComment comm _) : commRest) -> \lastSpanEnd -> do
+        case ExactPrint.ss2delta lastSpanEnd span of
+          SameLine i -> do
+            finalYield $ SamelineComment (i, comm)
+          DifferentLine l c -> do
+            finalYield $ EmptyLines (l - 1)
+            finalYield $ NewlineComment (c - 1, comm)
+        flattenComms commRest (ExactPrint.ss2posEnd span)
+    flattenDecls
+      :: [LImportDecl GhcPs]
+      -> ExactPrint.Pos
+      -> FinalList ImportLine ExactPrint.Pos
+    flattenDecls = \case
+      [] -> finalPure
+      (L (SrcSpanAnn epAnn srcSpan@(RealSrcSpan declSpan _)) decl : declRest)
+        -> \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
+      (L (SrcSpanAnn _epAnn UnhelpfulSpan{}) _decl : _declRest) ->
+        error "UnhelpfulSpan"
+  in
+    flattenDecls is startPos
+
+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 -> finalYield $ NewlineComment comm
+    PartialImport partialRecord ->
+      finalYield $ ImportStatement $ unpartial partialRecord
+  go acc (line1 : lineR) = do
+    newAcc <- case acc of
+      PartialCommsOnly comms -> case line1 of
+        e@EmptyLines{} -> do
+          reverse comms `forM_` \comm -> finalYield $ NewlineComment comm
+          finalYield e
+          pure $ PartialCommsOnly []
+        SamelineComment comm -> do
+          pure $ PartialCommsOnly (comm : 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
+          finalYield e
+          pure $ PartialCommsOnly []
+        SamelineComment comm -> do
+          if (null $ commentsAfter partialRecord)
+            then pure $ PartialImport partialRecord
+              { commentsSameline = comm : commentsSameline partialRecord
+              }
+            else pure $ PartialImport partialRecord
+              { commentsAfter = comm : commentsAfter partialRecord
+              }
+        NewlineComment comm -> pure $ PartialImport $ partialRecord
+          { commentsAfter = comm : commentsAfter partialRecord
+          }
+        ImportStatement record -> do
+          let contestedComments = commentsAfter partialRecord
+          finalYield $ ImportStatement $ unpartial $ partialRecord
+            { commentsAfter = []
+            }
+          pure $ PartialImport $ record { commentsBefore = contestedComments }
+            -- comments in between will stay connected to the following decl
+    go newAcc lineR
+  unpartial :: ImportStatementRecord -> ImportStatementRecord
+  unpartial partialRecord = ImportStatementRecord
+    { commentsBefore   = reverse (commentsBefore partialRecord)
+    , importStatement  = importStatement partialRecord
+    , commentsSameline = reverse (commentsSameline partialRecord)
+    , commentsAfter    = reverse (commentsAfter partialRecord)
+    }
+
+
+sortCommentedImports :: [ImportLine] -> [ImportLine]
+sortCommentedImports =
+  -- TODO92 we don't need this unpackImports, it is implied later in the process
+                       mergeGroups . map (fmap (sortGroups)) . groupify
+ where
+  -- unpackImports :: [ImportLine] -> [ImportLine]
+  -- unpackImports xs = xs >>= \case
+  --   l@EmptyLines{}      -> [l]
+  --   l@NewlineComment{}  -> [l]
+  --   l@SamelineComment{} -> [l]
+  --   ImportStatement r ->
+  --     map NewlineComment (commentsBefore r) ++ [ImportStatement r] ++ map
+  --       NewlineComment
+  --       (commentsAfter r)
+  mergeGroups :: [Either ImportLine [ImportStatementRecord]] -> [ImportLine]
+  mergeGroups xs = xs >>= \case
+    Left  x -> [x]
+    Right y -> ImportStatement <$> y
+  sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord]
+  sortGroups =
+    List.sortOn (moduleNameString . unLoc . ideclName . unLoc . importStatement)
+  groupify :: [ImportLine] -> [Either ImportLine [ImportStatementRecord]]
+  groupify cs = go [] cs
+   where
+    go [] = \case
+      (l@EmptyLines{}      : rest) -> Left l : go [] rest
+      (l@NewlineComment{}  : rest) -> Left l : go [] rest
+      (l@SamelineComment{} : rest) -> Left l : go [] rest
+      (ImportStatement r   : rest) -> go [r] rest
+      []                           -> []
+    go acc = \case
+      (l@EmptyLines{}      : rest) -> Right (reverse acc) : Left l : go [] rest
+      (l@NewlineComment{}  : rest) -> Left l : Right (reverse acc) : go [] rest
+      (l@SamelineComment{} : rest) -> Left l : Right (reverse acc) : go [] rest
+      (ImportStatement r   : rest) -> go (r : acc) rest
+      []                           -> [Right (reverse acc)]

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

@@ -0,0 +1,741 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Language.Haskell.Brittany.Internal.S3_ToBriDocTools where
+
+import qualified Control.Monad.Writer.Strict   as Writer
+import qualified Data.Char                     as Char
+import           Data.Data
+import qualified Data.Generics                 as SYB
+import qualified Data.Sequence                 as Seq
+import qualified Data.Text                     as Text
+import           DataTreePrint
+import           GHC                            ( EpAnn(EpAnn, EpAnnNotUsed)
+                                                , EpAnnComments
+                                                  ( EpaComments
+                                                  , EpaCommentsBalanced
+                                                  )
+                                                , GenLocated(L)
+                                                , LEpaComment
+                                                , Located
+                                                , LocatedA
+                                                , moduleName
+                                                , moduleNameString
+                                                )
+import qualified GHC
+import           GHC.Data.FastString            ( FastString )
+import qualified GHC.OldList                   as List
+import           GHC.Parser.Annotation          ( AnnKeywordId(..) )
+import           GHC.Types.Name                 ( getOccString )
+import           GHC.Types.Name.Occurrence      ( occNameString )
+import           GHC.Types.Name.Reader          ( RdrName(..) )
+import qualified GHC.Types.SrcLoc              as GHC
+import           GHC.Utils.Outputable           ( Outputable )
+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.Types
+import           Language.Haskell.Brittany.Internal.Utils
+import qualified Language.Haskell.GHC.ExactPrint
+                                               as ExactPrint
+import qualified Language.Haskell.GHC.ExactPrint.Utils
+                                               as ExactPrint
+
+
+
+-- | Use ExactPrint's output for this node; add a newly generated inline comment
+-- at insertion position (meant to point out to the user that this node is
+-- not handled by brittany yet). Useful when starting implementing new
+-- syntactic constructs when children are not handled yet.
+briDocByExact
+  :: (ExactPrint.ExactPrint ast, Data ast)
+  => LocatedA ast
+  -> ToBriDocM BriDocNumbered
+briDocByExact ast = do
+  traceIfDumpConf
+    "ast"
+    _dconf_dump_ast_unknown
+    (printTreeWithCustom 160 customLayouterF ast)
+  mModify (+ connectedCommentCount ast)
+  docExt ast True
+
+-- | Use ExactPrint's output for this node.
+-- Consider that for multi-line input, the indentation of the code produced
+-- by ExactPrint might be different, and even incompatible with the indentation
+-- of its surroundings as layouted by brittany. But there are safe uses of
+-- this, e.g. for any top-level declarations.
+briDocByExactNoComment
+  :: (ExactPrint.ExactPrint (GenLocated l ast), Data ast, Data l)
+  => GenLocated l ast
+  -> ToBriDocM BriDocNumbered
+briDocByExactNoComment ast = do
+  traceIfDumpConf
+    "ast"
+    _dconf_dump_ast_unknown
+    (printTreeWithCustom 160 customLayouterF ast)
+  mModify (+ connectedCommentCount ast)
+  docExt ast False
+
+-- | Use ExactPrint's output for this node, presuming that this output does
+-- not contain any newlines. If this property is not met, the semantics
+-- depend on the @econf_AllowRiskyExactPrintUse@ config flag.
+briDocByExactInlineOnly
+  :: ( ExactPrint.ExactPrint (GHC.XRec GhcPs a)
+     , Data (GHC.XRec GhcPs a)
+     , Data a
+     , Data (GHC.Anno a)
+     , Outputable (GHC.Anno a)
+     )
+  => String
+  -> GHC.XRec GhcPs a
+  -> ToBriDocM BriDocNumbered
+briDocByExactInlineOnly infoStr ast = do
+  traceIfDumpConf
+    "ast"
+    _dconf_dump_ast_unknown
+    (printTreeWithCustom 160 customLayouterF ast)
+  let exactPrinted = Text.pack $ ExactPrint.exactPrint ast
+  fallbackMode <-
+    mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack
+  let
+    exactPrintNode t =
+      allocateNode $ BDFExternal
+      -- (ExactPrint.Types.mkAnnKey ast)
+      -- (foldedAnnKeys ast)
+                                 False t
+  let
+    errorAction = do
+      mTell [ErrorUnknownNode infoStr ast]
+      docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"
+  mModify (+ connectedCommentCount ast)
+  case (fallbackMode, Text.lines exactPrinted) of
+    (ExactPrintFallbackModeNever, _) -> errorAction
+    (_, [t]) -> exactPrintNode
+      (Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t)
+    (ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted
+    _ -> errorAction
+
+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
+
+lrdrNameToText :: GenLocated l RdrName -> Text
+lrdrNameToText (L _ n) = rdrNameToText n
+
+class PrintRdrNameWithAnns l where
+  printRdrNameWithAnns :: GenLocated l RdrName -> Text
+
+instance PrintRdrNameWithAnns GHC.SrcSpanAnnN where
+  printRdrNameWithAnns (L (GHC.SrcSpanAnn epAnn _) name) =
+    case epAnn of
+      EpAnn _ (GHC.NameAnn GHC.NameParens _ _ _ _) _ -> f "(" name ")"
+      EpAnn _ (GHC.NameAnn GHC.NameParensHash _ _ _ _) _ -> f "(#" name "#)"
+      EpAnn _ (GHC.NameAnn GHC.NameBackquotes _ _ _ _) _ -> f "`" name "`"
+      EpAnn _ (GHC.NameAnn GHC.NameSquare _ _ _ _) _ -> f "[" name "]"
+      -- TODO92 There are way more possible constructors here
+      -- see https://hackage.haskell.org/package/ghc-9.2.5/docs/GHC-Parser-Annotation.html#t:NameAnn
+      EpAnn _ _ _ -> rdrNameToText name
+      EpAnnNotUsed -> rdrNameToText name
+   where
+    f a b c = Text.pack a <> rdrNameToText b <> Text.pack c
+
+lrdrNameToTextAnnGen
+  :: (MonadMultiReader Config m, PrintRdrNameWithAnns l)
+  => (Text -> Text)
+  -> GenLocated l RdrName
+  -> m Text
+  -- TODO this doesn't need to be monadic. I am pretty sure it started of as
+  -- a pure function, then at some point annotations were inspected
+  -- (from reader) but now it is pure again.
+  -- Leaving it as pseudo-monadic is harmless though (I think? Maybe I should
+  -- check I don't force some mapM/sequence/… garbage at common callsides
+    -- for this).
+lrdrNameToTextAnnGen f ast = pure $ f $ printRdrNameWithAnns ast
+
+lrdrNameToTextAnn
+  :: (MonadMultiReader Config m, PrintRdrNameWithAnns l)
+  => GenLocated l RdrName
+  -> m Text
+lrdrNameToTextAnn = lrdrNameToTextAnnGen id
+
+lrdrNameToTextAnnTypeEqualityIsSpecial
+  :: (MonadMultiReader Config m, PrintRdrNameWithAnns l)
+  => GenLocated l RdrName
+  -> m Text
+lrdrNameToTextAnnTypeEqualityIsSpecial ast = do
+  let
+    f x = if x == Text.pack "Data.Type.Equality~"
+      then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
+      else x
+  lrdrNameToTextAnnGen f ast
+
+-- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects
+-- the annotations for a (parent) node for a tick to be added to the
+-- literal.
+-- Excessively long name to reflect on us having to work around such
+-- excessively obscure special cases in the exactprint API.
+lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick
+  :: (MonadMultiReader Config m, PrintRdrNameWithAnns l)
+  => Located ast
+  -> GenLocated l RdrName
+  -> m Text
+lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick _ast1 ast2 = do
+  -- TODO92
+  -- hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote
+  x <- lrdrNameToTextAnn ast2
+  let
+    lit = if x == Text.pack "Data.Type.Equality~"
+      then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
+      else x
+  return lit -- $ if hasQuote then Text.cons '\'' lit else lit
+
+askIndent :: (MonadMultiReader Config m) => m Int
+askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk
+
+-- TODO92 this is not filtering enough yet, see old code below
+hasAnyCommentsBelow :: Data ast => ast -> Bool
+hasAnyCommentsBelow =
+  getAny . SYB.everything (<>) (SYB.mkQ (Any False) (\(_ :: LEpaComment) -> Any True))
+-- -- | True if there are any comments that are
+-- -- a) connected to any node below (in AST sense) the given node AND
+-- -- b) after (in source code order) the node.
+-- hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool
+-- hasAnyCommentsBelow ast@(L l _) =
+--   List.any (\(c, _) -> ExactPrint.commentIdentifier c > ExactPrint.Utils.rs l)
+--     <$> astConnectedComments ast
+
+-- extractRestComments
+--   :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)]
+-- extractRestComments ann =
+--   ExactPrint.annFollowingComments ann
+--     ++ (ExactPrint.annsDP ann >>= \case
+--          (ExactPrint.AnnComment com, dp) -> [(com, dp)]
+--          _ -> []
+--        )
+
+-- filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns
+-- filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast)
+
+hasCommentsBetween
+  :: Data ast
+  => ast
+  -> Maybe GHC.RealSrcLoc
+  -> Maybe GHC.RealSrcLoc
+  -> Bool
+hasCommentsBetween ast left right = do
+  getAny $ SYB.everything
+    (<>)
+    (SYB.mkQ
+      (Any False)
+      (\(L (GHC.Anchor pos _) _ :: LEpaComment) -> Any
+        (  (maybe True (GHC.realSrcSpanStart pos >=) left)
+        && (maybe True (GHC.realSrcSpanEnd pos <=) right)
+        )
+      )
+    )
+    ast
+
+
+
+  -- mAnn <- astAnn ast
+  -- let
+  --   go1 [] = False
+  --   go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest
+  --   go1 (_ : rest) = go1 rest
+  --   go2 [] = False
+  --   go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True
+  --   go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False
+  --   go2 (_ : rest) = go2 rest
+  -- case mAnn of
+  --   Nothing -> pure False
+  --   Just ann -> pure $ go1 $ ExactPrint.annsDP ann
+
+-- | True if there are any comments that are connected to any node below (in AST
+--   sense) the given node
+hasAnyCommentsConnected :: (Data ann, Data ast) => GHC.GenLocated ann ast -> Bool
+hasAnyCommentsConnected =
+  getAny . SYB.everything (<>) (SYB.mkQ (Any False) (\(_ :: LEpaComment) -> Any True))
+
+connectedCommentCount :: (Data ann, Data ast) => GHC.GenLocated ann ast -> CommentCounter
+connectedCommentCount =
+  getSum . SYB.everything (<>) (SYB.mkQ (Sum 0) (\(_ :: LEpaComment) -> Sum 1))
+
+-- | True if there are any regular comments connected to any node below (in AST
+--   sense) the given node
+-- hasAnyRegularCommentsConnected :: GenLocated ann ast -> Bool
+-- hasAnyRegularCommentsConnected ast =
+--   any isRegularComment $ astConnectedComments ast
+
+-- | Regular comments are comments that are actually "source code comments",
+-- i.e. things that start with "--" or "{-". In contrast to comment-annotations
+-- used by ghc-exactprint for capturing symbols (and their exact positioning).
+--
+-- Only the type instance layouter makes use of this filter currently, but
+-- it might make sense to apply it more aggressively or make it the default -
+-- I believe that most of the time we branch on the existence of comments, we
+-- only care about "regular" comments. We simply did not need the distinction
+-- because "irregular" comments are not that common outside of type/data decls.
+-- isRegularComment :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> Bool
+-- isRegularComment = (== Nothing) . ExactPrint.Types.commentOrigin . fst
+
+astConnectedComments
+  :: (Data ann, Data ast)
+  => GHC.GenLocated ann ast
+  -> [LEpaComment]
+astConnectedComments =
+  SYB.listify (\(_ :: LEpaComment) -> True)
+  -- anns <- filterAnns ast <$> mAsk
+  -- pure $ extractAllComments =<< Map.elems anns
+-- 
+-- hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool
+-- hasAnyCommentsPrior ast = astAnn ast <&> \case
+--   Nothing -> False
+--   Just (ExactPrint.Types.Ann _ priors _ _ _ _) -> not $ null priors
+
+-- hasAnyRegularCommentsRest :: Data ast => GHC.Located ast -> ToBriDocM Bool
+-- hasAnyRegularCommentsRest ast = astAnn ast <&> \case
+--   Nothing -> False
+--   Just ann -> any isRegularComment (extractRestComments ann)
+
+-- hasAnnKeywordComment
+--   :: GHC.LocatedA ast -> AnnKeywordId -> Bool
+-- hasAnnKeywordComment (L (GHC.SrcSpanAnn ann _) _) annKeyword = False -- _ ann
+  -- Nothing -> False
+  -- Just ann -> any hasK (extractAllComments ann)
+  -- where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst
+
+-- new BriDoc stuff
+
+allocateNode
+  :: MonadMultiState NodeAllocIndex m => BriDocFInt -> m BriDocNumbered
+allocateNode bd = do
+  i <- allocNodeIndex
+  return (i, bd)
+
+allocNodeIndex :: MonadMultiState NodeAllocIndex m => m Int
+allocNodeIndex = do
+  NodeAllocIndex i <- mGet
+  mSet $ NodeAllocIndex (i + 1)
+  return i
+
+docEmpty :: ToBriDocM BriDocNumbered
+docEmpty = allocateNode BDFEmpty
+
+docLit :: Text -> ToBriDocM BriDocNumbered
+docLit t = allocateNode $ BDFLit t
+
+docLitS :: String -> ToBriDocM BriDocNumbered
+docLitS s = allocateNode $ BDFLit $ Text.pack s
+
+docExt
+  :: (ExactPrint.ExactPrint (GenLocated l ast))
+  => GenLocated l ast
+  -> Bool
+  -> ToBriDocM BriDocNumbered
+docExt x shouldAddComment = allocateNode $ BDFExternal
+    -- (ExactPrint.Types.mkAnnKey x)
+    -- (foldedAnnKeys x)
+  shouldAddComment
+  (Text.pack
+  $ List.dropWhile ((==) '\n')
+  $ ExactPrint.exactPrint
+  $ ExactPrint.makeDeltaAst x
+  )
+
+docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
+docAlt l = allocateNode . BDFAlt =<< sequence l
+
+newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a)
+  deriving (Functor, Applicative, Monad)
+
+addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM ()
+addAlternativeCond cond doc = when cond (addAlternative doc)
+
+addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM ()
+addAlternative = CollectAltM . Writer.tell . (: [])
+
+runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered
+runFilteredAlternative (CollectAltM action) = docAlt $ Writer.execWriter action
+
+
+docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
+docSeq [] = docEmpty
+docSeq l = allocateNode . BDFSeq =<< sequence l
+
+docLines :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
+docLines l = allocateNode . BDFLines =<< sequence l
+
+docCols :: ColSig -> [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
+docCols sig l = allocateNode . BDFCols sig =<< sequence l
+
+docAddBaseY :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
+docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm
+
+docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
+docSetBaseY bdm = do
+  bd <- bdm
+  -- the order here is important so that these two nodes can be treated
+  -- properly over at `transformAlts`.
+  n1 <- allocateNode $ BDFBaseYPushCur bd
+  n2 <- allocateNode $ BDFBaseYPop n1
+  return n2
+
+docSetIndentLevel :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
+docSetIndentLevel bdm = do
+  bd <- bdm
+  n1 <- allocateNode $ BDFIndentLevelPushCur bd
+  n2 <- allocateNode $ BDFIndentLevelPop n1
+  return n2
+
+docSetBaseAndIndent :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
+docSetBaseAndIndent = docSetBaseY . docSetIndentLevel
+
+docSeparator :: ToBriDocM BriDocNumbered
+docSeparator = allocateNode BDFSeparator
+
+docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
+docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing False =<< bdm
+
+docNonBottomSpacingS :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
+docNonBottomSpacingS bdm = allocateNode . BDFNonBottomSpacing True =<< bdm
+
+docSetParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
+docSetParSpacing bdm = allocateNode . BDFSetParSpacing =<< bdm
+
+docForceParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
+docForceParSpacing bdm = allocateNode . BDFForceParSpacing =<< bdm
+
+docDebug :: String -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
+docDebug s bdm = allocateNode . BDFDebug s =<< bdm
+
+appSep :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
+appSep x = docSeq [x, docSeparator]
+
+docCommaSep :: ToBriDocM BriDocNumbered
+docCommaSep = appSep $ docLit $ Text.pack ","
+
+docParenLSep :: ToBriDocM BriDocNumbered
+docParenLSep = appSep docParenL
+
+-- TODO: we don't make consistent use of these (yet). However, I think the
+-- most readable approach overall might be something else: define
+-- `lit = docLit . Text.pack` and `prepSep = docSeq [docSeparator, x]`.
+-- I think those two would make the usage most readable.
+-- lit "("  and  appSep (lit "(")  are understandable and short without
+-- introducing a new top-level binding for all types of parentheses.
+docParenL :: ToBriDocM BriDocNumbered
+docParenL = docLit $ Text.pack "("
+
+docParenR :: ToBriDocM BriDocNumbered
+docParenR = docLit $ Text.pack ")"
+
+docParenHashLSep :: ToBriDocM BriDocNumbered
+docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator]
+
+docParenHashRSep :: ToBriDocM BriDocNumbered
+docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"]
+
+docBracketL :: ToBriDocM BriDocNumbered
+docBracketL = docLit $ Text.pack "["
+
+docBracketR :: ToBriDocM BriDocNumbered
+docBracketR = docLit $ Text.pack "]"
+
+
+docTick :: ToBriDocM BriDocNumbered
+docTick = docLit $ Text.pack "'"
+
+
+docPar
+  :: ToBriDocM BriDocNumbered
+  -> ToBriDocM BriDocNumbered
+  -> ToBriDocM BriDocNumbered
+docPar lineM indentedM = do
+  line <- lineM
+  indented <- indentedM
+  allocateNode $ BDFPar BrIndentNone line indented
+
+docForceSingleline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
+docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm
+
+docForceMultiline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
+docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm
+
+docEnsureIndent
+  :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
+docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd
+
+
+docFlushRemaining :: FastString -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
+docFlushRemaining fileThing = docFlushCommsPost
+  (Just $ GHC.mkRealSrcLoc fileThing 999999 999999)
+
+-- CLASS DocHandleComms --------------------------------------------------------
+
+class DocHandleComms ann a where
+  docHandleComms :: HasCallStack => ann -> a -> a
+
+instance DocHandleComms [LEpaComment] (ToBriDocM BriDocNumbered) where
+  docHandleComms comms bdm = do
+    bd <- bdm
+    i1 <- allocNodeIndex
+    pure (i1, BDFQueueComments comms bd)
+
+instance DocHandleComms (EpAnn a) (ToBriDocM BriDocNumbered) where
+  docHandleComms epAnn bdm = case epAnn of
+    EpAnn anch _ (EpaComments []) -> do
+      bd <- bdm
+      i1 <- allocNodeIndex
+      pure
+        (i1, BDFFlushCommentsPrior (GHC.realSrcSpanStart $ GHC.anchor anch) bd)
+    EpAnn anch _ (EpaComments comms) -> do
+      bd <- bdm
+      i1 <- allocNodeIndex
+      i2 <- allocNodeIndex
+      pure
+        ( i1
+        , BDFFlushCommentsPrior (GHC.realSrcSpanStart $ GHC.anchor anch)
+                                (i2, BDFQueueComments (reverse comms) bd)
+        )
+    EpAnn anch _ (EpaCommentsBalanced commsB commsA) -> do
+      bd <- bdm
+      i1 <- allocNodeIndex
+      i2 <- allocNodeIndex
+      pure
+        ( i1
+        , BDFQueueComments
+          (reverse commsB ++ reverse commsA)
+          ( i2
+          , BDFFlushCommentsPrior (GHC.realSrcSpanStart $ GHC.anchor anch) bd
+          )
+        )
+    EpAnnNotUsed -> bdm
+
+instance DocHandleComms (GHC.RealSrcSpan) (ToBriDocM BriDocNumbered) where
+  docHandleComms loc = docHandleComms (GHC.realSrcSpanStart loc)
+
+instance DocHandleComms (GHC.RealSrcLoc) (ToBriDocM BriDocNumbered) where
+  docHandleComms loc bdm = do
+    bd <- bdm
+    i1 <- allocNodeIndex
+    pure (i1, BDFFlushCommentsPrior loc bd)
+
+instance DocHandleComms (Maybe GHC.RealSrcSpan) (ToBriDocM BriDocNumbered) where
+  docHandleComms Nothing bdm = bdm
+  docHandleComms (Just loc) bdm = docHandleComms loc bdm
+
+instance DocHandleComms (Maybe GHC.RealSrcLoc) (ToBriDocM BriDocNumbered) where
+  docHandleComms Nothing bdm = bdm
+  docHandleComms (Just loc) bdm = docHandleComms loc bdm
+
+instance DocHandleComms (GHC.SrcLoc) (ToBriDocM BriDocNumbered) where
+  docHandleComms (GHC.RealSrcLoc loc _) bdm = docHandleComms loc bdm
+  docHandleComms (GHC.UnhelpfulLoc _) bdm = bdm
+
+instance DocHandleComms (GHC.LocatedA ast) (ToBriDocM BriDocNumbered) where
+  docHandleComms (L (GHC.SrcSpanAnn epAnn span) _) bdm = case span of
+    GHC.RealSrcSpan s _ -> docHandleComms s $ docHandleComms epAnn bdm
+    GHC.UnhelpfulSpan _ -> bdm
+
+instance DocHandleComms (GHC.LocatedL ast) (ToBriDocM BriDocNumbered) where
+  docHandleComms (L (GHC.SrcSpanAnn epAnn span) _) bdm = case span of
+    GHC.RealSrcSpan s _ -> docHandleComms s $ docHandleComms epAnn bdm
+    GHC.UnhelpfulSpan _ -> bdm
+
+instance DocHandleComms (GHC.LocatedC ast) (ToBriDocM BriDocNumbered) where
+  docHandleComms (L (GHC.SrcSpanAnn epAnn span) _) bdm = case span of
+    GHC.RealSrcSpan s _ -> docHandleComms s $ docHandleComms epAnn bdm
+    GHC.UnhelpfulSpan _ -> bdm
+
+instance DocHandleComms (GHC.LocatedN ast) (ToBriDocM BriDocNumbered) where
+  docHandleComms (L (GHC.SrcSpanAnn epAnn span) _) bdm = case span of
+    GHC.RealSrcSpan s _ -> docHandleComms s $ docHandleComms epAnn bdm
+    GHC.UnhelpfulSpan _ -> bdm
+
+
+instance DocHandleComms ann (ToBriDocM BriDocNumbered)
+      => DocHandleComms ann (ToBriDocM [BriDocNumbered]) where
+  docHandleComms ann bdm = do
+    x <- bdm
+    case x of
+      [] -> error "docHandleComms empty list"
+        -- TODO92
+        -- do
+        -- el <- docHandleComms ann docEmpty
+        -- pure [el]
+      (bd1:bdR) -> do
+        bd1' <- docHandleComms ann (pure bd1)
+        pure (bd1':bdR)
+
+instance DocHandleComms ann (ToBriDocM BriDocNumbered)
+      => DocHandleComms ann (ToBriDocM (Seq BriDocNumbered))
+ where
+  docHandleComms ast bdsm = do
+    bds <- bdsm
+    case Seq.viewl bds of
+      Seq.EmptyL -> return Seq.empty -- TODO: this might be bad. maybe. then again, not really. well.
+      bd1 Seq.:< rest -> do
+        bd1' <- docHandleComms ast (return bd1)
+        return $ bd1' Seq.<| rest
+
+
+instance DocHandleComms ann (ToBriDocM BriDocNumbered)
+      => DocHandleComms ann [ToBriDocM BriDocNumbered] where
+  docHandleComms ann bdms = do
+    case bdms of
+      [] -> error "docHandleComms empty list"
+       -- [docHandleComms ann docEmpty]
+      (bd1:bdR) -> (docHandleComms ann bd1:bdR)
+
+instance DocHandleComms GHC.EpaLocation (ToBriDocM BriDocNumbered) where
+  docHandleComms loc bdm = docHandleComms (GHC.epaLocationRealSrcSpan loc) bdm
+
+instance DocHandleComms GHC.SrcSpan (ToBriDocM BriDocNumbered) where
+  docHandleComms (GHC.RealSrcSpan s _) bdm = docHandleComms s bdm
+  docHandleComms (GHC.UnhelpfulSpan _) bdm = bdm
+
+
+-- CLASS ObtainAnnPos ----------------------------------------------------------
+
+class ObtainAnnPos key ann where
+  obtainAnnPos :: ann -> key -> Maybe GHC.RealSrcLoc
+
+instance ObtainAnnPos AnnKeywordId GHC.AddEpAnn where
+  obtainAnnPos (GHC.AddEpAnn eKW loc) kw = if eKW == kw
+    then Just (epaLocationRealSrcSpanStart loc)
+    else Nothing
+
+instance ObtainAnnPos AnnKeywordId (EpAnn GHC.AnnsModule) where
+  obtainAnnPos = \case
+    EpAnnNotUsed -> \_kw -> Nothing
+    EpAnn _ (GHC.AnnsModule l annList) _ -> \kw ->
+      obtainAnnPos l kw <|> obtainAnnPos annList kw
+
+instance ObtainAnnPos AnnKeywordId (Maybe GHC.AddEpAnn) where
+  obtainAnnPos Nothing _ = Nothing
+  obtainAnnPos (Just addEpAnn) kw = obtainAnnPos addEpAnn kw
+
+instance ObtainAnnPos AnnKeywordId [GHC.AddEpAnn] where
+  obtainAnnPos list kw =
+    case [ loc | GHC.AddEpAnn eKW loc <- list, eKW == kw ] of
+      []   -> Nothing
+      locs -> Just (epaLocationRealSrcSpanStart $ minimum locs)
+
+instance ObtainAnnPos AnnKeywordId (EpAnn [GHC.AddEpAnn]) where
+  obtainAnnPos EpAnnNotUsed _kw = Nothing
+  obtainAnnPos (EpAnn _ list _) kw = obtainAnnPos list kw
+
+instance ObtainAnnPos AnnKeywordId (EpAnn GHC.AnnList) where
+  obtainAnnPos = \case
+    EpAnnNotUsed -> \_kw -> Nothing
+    EpAnn _ annList _ -> \kw -> obtainAnnPos annList kw
+
+instance ObtainAnnPos AnnKeywordId GHC.AnnList where
+  obtainAnnPos (GHC.AnnList _ op cl addEpAnn _) kw =
+    obtainAnnPos op kw <|> obtainAnnPos cl kw <|> obtainAnnPos addEpAnn kw
+
+instance ObtainAnnPos AnnKeywordId (EpAnn GHC.GrhsAnn) where
+  obtainAnnPos = \case
+    EpAnn _ (GHC.GrhsAnn _ addEpAnn) _ -> obtainAnnPos addEpAnn
+    EpAnnNotUsed                       -> \_kw -> Nothing
+
+instance ObtainAnnPos AnnKeywordId GHC.SrcSpanAnnL where
+  obtainAnnPos = \case
+    GHC.SrcSpanAnn epAnn _ -> obtainAnnPos epAnn
+
+class ObtainAnnPos AnnKeywordId ann => ObtainAnnDeltaPos ann where
+  obtainAnnDeltaPos :: ann -> AnnKeywordId -> Maybe GHC.DeltaPos
+
+instance ObtainAnnDeltaPos (EpAnn GHC.AnnsModule) where
+  obtainAnnDeltaPos = \case
+    EpAnnNotUsed                          -> \_kw -> Nothing
+    EpAnn _ (GHC.AnnsModule l annList) epaComms -> \kw -> do
+      loc <- obtainAnnPos l kw <|> obtainAnnPos annList kw
+      let pos = (GHC.srcLocLine loc, GHC.srcLocCol loc)
+      pure $ ExactPrint.pos2delta
+        (maximum $ (0, 1) :
+          [ ExactPrint.ss2posEnd $ GHC.anchor anch
+          | L anch _ <- case epaComms of
+            EpaCommentsBalanced cs1 cs2 -> cs1 ++ cs2
+            EpaComments cs              -> cs
+          , let compPos = ExactPrint.ss2posEnd (GHC.anchor anch)
+          , compPos <= pos
+          ]
+        )
+        pos
+
+class DocFlushCommsPost a where
+  docFlushCommsPost :: Maybe GHC.RealSrcLoc -> a -> a
+
+instance DocFlushCommsPost (ToBriDocM BriDocNumbered) where
+  docFlushCommsPost = \case
+    Nothing   -> id
+    Just span -> \bdm -> do
+      i1 <- allocNodeIndex
+      bd <- bdm
+      pure (i1, BDFFlushCommentsPost span bd)
+
+instance DocFlushCommsPost (ToBriDocM [BriDocNumbered]) where
+  docFlushCommsPost loc bdm = do
+    bds <- bdm
+    case bds of
+      [] -> do
+        e <- docFlushCommsPost loc docEmpty
+        pure [e]
+      _ -> do
+        e <- docFlushCommsPost loc (pure $ List.last bds)
+        pure (List.init bds ++ [e])
+
+unknownNodeError
+  :: (Data a, Data (GHC.Anno a), Outputable (GHC.Anno a))
+  => String
+  -> GHC.XRec GhcPs a
+  -> ToBriDocM BriDocNumbered
+unknownNodeError infoStr ast = do
+  mTell [ErrorUnknownNode infoStr ast]
+  docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"
+
+spacifyDocs :: [ToBriDocM BriDocNumbered] -> [ToBriDocM BriDocNumbered]
+spacifyDocs [] = []
+spacifyDocs ds = fmap appSep (List.init ds) ++ [List.last ds]
+
+shareDoc :: ToBriDocM a -> ToBriDocM (ToBriDocM a)
+shareDoc = fmap pure
+
+
+obtainListElemStartCommaLocs
+  :: LocatedA ast -> (Maybe GHC.RealSrcLoc, Maybe GHC.RealSrcLoc)
+obtainListElemStartCommaLocs = \case
+  L (GHC.SrcSpanAnn elemEpAnn _) _ -> case elemEpAnn of
+    EpAnn anch (GHC.AnnListItem [item]) _ ->
+      ( Just $ GHC.realSrcSpanStart $ GHC.anchor anch
+        -- yes, we want `realSrcSpanStart span2` here, but have it flow
+        -- to the end of bd. We want any comments _before_ the _start_
+        -- of the comma to be inserted _after_ the element.
+      , Just $ GHC.realSrcSpanStart $ case item of
+        GHC.AddCommaAnn   span -> GHC.epaLocationRealSrcSpan span
+        GHC.AddSemiAnn    span -> GHC.epaLocationRealSrcSpan span
+        GHC.AddVbarAnn    span -> GHC.epaLocationRealSrcSpan span
+        GHC.AddRarrowAnn  span -> GHC.epaLocationRealSrcSpan span
+        GHC.AddRarrowAnnU span -> GHC.epaLocationRealSrcSpan span
+        GHC.AddLollyAnnU  span -> GHC.epaLocationRealSrcSpan span
+      )
+    EpAnn anch _ _ -> (Just $ GHC.realSrcSpanStart $ GHC.anchor anch, Nothing)
+    EpAnnNotUsed   -> (Nothing, Nothing)
+
+
+docHandleListElemComms
+  :: (LocatedA ast -> ToBriDocM BriDocNumbered)
+  -> LocatedA ast
+  -> ToBriDocM BriDocNumbered
+docHandleListElemComms layouter e = case obtainListElemStartCommaLocs e of
+  (posStart, posComma) ->
+    docHandleComms posStart $ docFlushCommsPost posComma $ layouter e
+
+epaLocationRealSrcSpanStart :: GHC.EpaLocation -> GHC.RealSrcLoc
+epaLocationRealSrcSpanStart = GHC.realSrcSpanStart . GHC.epaLocationRealSrcSpan

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

@@ -0,0 +1,316 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Language.Haskell.Brittany.Internal.S4_WriteBriDoc
+  ( ppBriDoc
+  )
+where
+
+import           Language.Haskell.Brittany.Internal.Prelude
+
+import qualified Control.Monad.Trans.MultiRWS.Strict
+                                               as MultiRWSS
+import qualified Data.Text                     as Text
+import qualified Data.Text.Lazy.Builder        as TextL.Builder
+import           GHC                            ( Anchor(Anchor)
+                                                , AnchorOperation
+                                                  ( MovedAnchor
+                                                  , UnchangedAnchor
+                                                  )
+                                                , EpaComment(EpaComment)
+                                                , EpaCommentTok
+                                                  ( EpaBlockComment
+                                                  , EpaDocCommentNamed
+                                                  , EpaDocCommentNext
+                                                  , EpaDocCommentPrev
+                                                  , EpaDocOptions
+                                                  , EpaDocSection
+                                                  , EpaEofComment
+                                                  , EpaLineComment
+                                                  )
+                                                , GenLocated(L)
+                                                , LEpaComment
+                                                , RealSrcLoc
+                                                )
+import           GHC.Types.SrcLoc               ( realSrcSpanEnd )
+import qualified GHC.OldList                   as List
+
+import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint
+
+import           Language.Haskell.Brittany.Internal.Config.Types
+import           Language.Haskell.Brittany.Internal.Transformations.T1_Alt
+import           Language.Haskell.Brittany.Internal.Transformations.T2_Floating
+import           Language.Haskell.Brittany.Internal.Transformations.T3_Par
+import           Language.Haskell.Brittany.Internal.Transformations.T4_Columns
+import           Language.Haskell.Brittany.Internal.Transformations.T5_Indent
+import           Language.Haskell.Brittany.Internal.Types
+import           Language.Haskell.Brittany.Internal.Utils
+import           Language.Haskell.Brittany.Internal.WriteBriDoc.AlignmentAlgo
+import           Language.Haskell.Brittany.Internal.WriteBriDoc.Types
+import           Language.Haskell.Brittany.Internal.WriteBriDoc.Operators
+import Language.Haskell.Brittany.Internal.Components.BriDoc
+-- import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
+
+
+ppBriDoc :: BriDocNumbered -> PPMLocal ()
+ppBriDoc briDoc = do
+  -- first step: transform the briDoc.
+  briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do
+    -- Note that briDoc is BriDocNumbered, but state type is BriDoc.
+    -- That's why the alt-transform looks a bit special here.
+    traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw
+      $ briDocToDoc
+      $ unwrapBriDocNumbered
+      $ briDoc
+    -- bridoc transformation: remove alts
+    transformAlts briDoc >>= mSet
+    mGet
+      >>= briDocToDoc
+      .>  traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt
+    -- bridoc transformation: float stuff in
+    mGet >>= transformSimplifyFloating .> mSet
+    mGet
+      >>= briDocToDoc
+      .>  traceIfDumpConf "bridoc post-floating"
+                          _dconf_dump_bridoc_simpl_floating
+    -- bridoc transformation: par removal
+    mGet >>= transformSimplifyPar .> mSet
+    mGet
+      >>= briDocToDoc
+      .>  traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par
+    -- bridoc transformation: float stuff in
+    mGet >>= transformSimplifyColumns .> mSet
+    mGet
+      >>= briDocToDoc
+      .>  traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns
+    -- bridoc transformation: indent
+    mGet >>= transformSimplifyIndent .> mSet
+    mGet
+      >>= briDocToDoc
+      .>  traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent
+    mGet
+      >>= briDocToDoc
+      .>  traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final
+    -- -- convert to Simple type
+    -- simpl <- mGet <&> transformToSimple
+    -- return simpl
+
+  let state = LayoutState { _lstate_baseYs           = [0]
+                          , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left
+                                             -- here because moveToAnn stuff
+                                             -- of the first node needs to do
+                                             -- its thing properly.
+                          , _lstate_indLevels        = [0]
+                          , _lstate_indLevelLinger   = 0
+                          , _lstate_commentCol       = Nothing
+                          , _lstate_addSepSpace      = Nothing
+                          , _lstate_commentNewlines  = 0
+                          }
+  state' <-
+    MultiRWSS.withMultiStateS state
+    $ MultiRWSS.withMultiStateS ([] :: [LEpaComment])
+    $ do
+      layoutBriDocM briDoc'
+      layoutWriteEnsureBlock
+  case _lstate_curYOrAddNewline state' of
+    Left{} -> mTell $ TextL.Builder.fromString "\n"
+    Right{} -> pure ()
+  pure ()
+
+
+layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m ()
+layoutBriDocM = \case
+  BDEmpty -> do
+    return () -- can it be that simple
+  BDLit t -> do
+    layoutIndentRestorePostComment
+    layoutRemoveIndentLevelLinger
+    layoutWriteAppend t
+  BDSeq list -> do
+    list `forM_` layoutBriDocM
+  -- in this situation, there is nothing to do about cols.
+  -- i think this one does not happen anymore with the current simplifications.
+  -- BDCols cSig list | BDPar sameLine lines <- List.last list ->
+  --   alignColsPar $ BDCols cSig (List.init list ++ [sameLine]) : lines
+  BDCols _ list -> do
+    list `forM_` layoutBriDocM
+  BDSeparator -> do
+    layoutAddSepSpace
+  BDAddBaseY indent bd -> do
+    let indentF = case indent of
+          BrIndentNone      -> id
+          BrIndentRegular   -> layoutWithAddBaseCol
+          BrIndentSpecial i -> layoutWithAddBaseColN i
+    indentF $ layoutBriDocM bd
+  BDBaseYPushCur bd -> do
+    layoutBaseYPushCur
+    layoutBriDocM bd
+  BDBaseYPop bd -> do
+    layoutBriDocM bd
+    layoutBaseYPop
+  BDIndentLevelPushCur bd -> do
+    layoutIndentLevelPushCur
+    layoutBriDocM bd
+  BDIndentLevelPop bd -> do
+    layoutBriDocM bd
+    layoutIndentLevelPop
+  BDEnsureIndent indent bd -> do
+    let indentF = case indent of
+          BrIndentNone      -> id
+          BrIndentRegular   -> layoutWithAddBaseCol
+          BrIndentSpecial i -> layoutWithAddBaseColN i
+    indentF $ do
+      layoutWriteEnsureBlock
+      layoutBriDocM bd
+  BDPar indent sameLine indented -> do
+    layoutBriDocM sameLine
+    let indentF = case indent of
+          BrIndentNone      -> id
+          BrIndentRegular   -> layoutWithAddBaseCol
+          BrIndentSpecial i -> layoutWithAddBaseColN i
+    indentF $ do
+      layoutWriteNewlineBlock
+      layoutBriDocM indented
+  BDLines           lines       -> alignColsLines layoutBriDocM lines
+  BDAlt             []          -> error "empty BDAlt"
+  BDAlt             (alt : _)   -> layoutBriDocM alt
+  BDForceMultiline  bd          -> layoutBriDocM bd
+  BDForceSingleline bd          -> layoutBriDocM bd
+  BDForwardLineMode bd          -> layoutBriDocM bd
+  BDExternal shouldAddComment t -> do
+    let tlines     = Text.lines $ t <> Text.pack "\n"
+        tlineCount = length tlines
+    when shouldAddComment $ do
+      layoutWriteAppend $ Text.pack $ "{- via external! -}"
+    zip [1 ..] tlines `forM_` \(i, l) -> do
+      layoutWriteAppend $ l
+      unless (i == tlineCount) layoutWriteNewlineBlock
+  BDPlain t -> do
+    layoutWriteAppend t
+  -- BDAnnotationPrior comms bd -> do
+  --   -- state <- mGet
+  --   -- let m = _lstate_comments state
+  --   -- let
+  --   --   moveToExactLocationAction = case _lstate_curYOrAddNewline state of
+  --   --     Left{} -> pure ()
+  --   --     Right{} -> moveToExactAnn annKey
+  --   -- case mAnn of
+  --   --   Nothing -> moveToExactLocationAction
+  --   --   Just [] -> moveToExactLocationAction
+  --   --   Just priors -> do
+  --   --     -- layoutResetSepSpace
+  --   --     priors
+  --   --       `forM_` \(ExactPrint.Types.Comment comment _ _, DifferentLine (y, x)) ->
+  --   --                 when (comment /= "(" && comment /= ")") $ do
+  --   --                   let commentLines = Text.lines $ Text.pack $ comment
+  --   --                   case comment of
+  --   --                     ('#' : _) ->
+  --   --                       layoutMoveToCommentPos y (-999) (length commentLines)
+  --   --                                --  ^ evil hack for CPP
+  --   --                     _ -> layoutMoveToCommentPos y x (length commentLines)
+  --   --                   -- fixedX <- fixMoveToLineByIsNewline x
+  --   --                   -- replicateM_ fixedX layoutWriteNewline
+  --   --                   -- layoutMoveToIndentCol y
+  --   --                   layoutWriteAppendMultiline commentLines
+  --   --       -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
+  --   --     moveToExactLocationAction
+  --   printComments comms
+  --   mModify (\s -> s + CommentCounter (length comms))
+  --   layoutBriDocM bd
+  -- BDAnnotationPost comms bd -> do
+  --   layoutBriDocM bd
+  --   printComments comms
+  --   mModify (\s -> s + CommentCounter (length comms))
+    -- annMay <- do
+    --   state <- mGet
+    --   let m = _lstate_comments state
+    --   pure $ Map.lookup annKey m
+    -- let mComments = nonEmpty . extractAllComments =<< annMay
+    -- -- let
+    -- --   semiCount = length
+    -- --     [ ()
+    -- --     | Just ann <- [annMay]
+    -- --     , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann
+    -- --     ]
+    -- shouldAddSemicolonNewlines <-
+    --   mAsk
+    --   <&> _conf_layout
+    --   .> _lconfig_experimentalSemicolonNewlines
+    --   .> confUnpack
+    -- case mComments of
+    --   Nothing -> do
+    --     when shouldAddSemicolonNewlines $ do
+    --       [1 .. semiCount] `forM_` const layoutWriteNewline
+    --   Just comments -> do
+    --     comments
+    --       `forM_` \(ExactPrint.Types.Comment comment _ _, DifferentLine (y, x)) ->
+    --                 when (comment /= "(" && comment /= ")") $ do
+    --                   let commentLines = Text.lines $ Text.pack comment
+    --                   case comment of
+    --                     ('#' : _) -> layoutMoveToCommentPos y (-999) 1
+    --                                --  ^ evil hack for CPP
+    --                     ")" -> pure ()
+    --                                --  ^ fixes the formatting of parens
+    --                                --    on the lhs of type alias defs
+    --                     _ -> layoutMoveToCommentPos y x (length commentLines)
+    --                   -- fixedX <- fixMoveToLineByIsNewline x
+    --                   -- replicateM_ fixedX layoutWriteNewline
+    --                   -- layoutMoveToIndentCol y
+    --                   layoutWriteAppendMultiline commentLines
+    --   -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
+  BDQueueComments comms bd -> do
+    existing :: [GHC.LEpaComment] <- mGet
+    mSet $ mergeOn (\(L l _) -> l) existing comms
+    layoutBriDocM bd
+  BDFlushCommentsPrior loc bd -> do
+    comms <- takeBefore loc
+    printComments comms
+    mModify (\s -> s + CommentCounter (length comms))
+    layoutBriDocM bd
+  BDFlushCommentsPost loc bd -> do
+    layoutBriDocM bd
+    comms <- takeBefore loc
+    mModify (\s -> s + CommentCounter (length comms))
+    printComments comms
+  BDNonBottomSpacing _ bd -> layoutBriDocM bd
+  BDSetParSpacing   bd    -> layoutBriDocM bd
+  BDForceParSpacing bd    -> layoutBriDocM bd
+  BDDebug s bd            -> do
+    mTell $ TextL.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}"
+    layoutBriDocM bd
+
+mergeOn :: Ord b => (a -> b) -> [a] -> [a] -> [a]
+mergeOn _f xs [] = xs
+mergeOn _f [] ys = ys
+mergeOn f xs@(x:xr) ys@(y:yr)
+    | f x <= f y = x : mergeOn f xr ys
+    | otherwise = y : mergeOn f xs yr
+
+takeBefore
+  :: MonadMultiState [LEpaComment] m => RealSrcLoc -> m [LEpaComment]
+takeBefore loc = do
+  comms <- mGet
+  let (before, after) = List.span
+        (\(L (Anchor spanC _) _) -> realSrcSpanEnd spanC <= loc)
+        comms
+  mSet after
+  pure before
+
+printComments :: LayoutConstraints m => [GHC.LEpaComment] -> m ()
+printComments comms = do
+  let
+    addComment s anchor prior = do
+      case anchor of
+        Anchor span UnchangedAnchor ->
+          moveToCommentPos True $ ExactPrint.ss2deltaEnd prior span
+        Anchor _span (MovedAnchor dp) -> moveToCommentPos False dp
+      -- ppmMoveToExactLoc $ ExactPrint.ss2deltaEnd prior span
+      layoutWriteAppend $ Text.pack s
+  comms `forM_` \case
+    L anch (EpaComment (EpaDocCommentNext s) prior) -> addComment s anch prior
+    L anch (EpaComment (EpaDocCommentPrev s) prior) -> addComment s anch prior
+    L anch (EpaComment (EpaDocCommentNamed s) prior) -> addComment s anch prior
+    L anch (EpaComment (EpaDocSection _ s) prior) -> addComment s anch prior
+    L anch (EpaComment (EpaDocOptions s) prior) -> addComment s anch prior
+    L anch (EpaComment (EpaLineComment s) prior) -> addComment s anch prior
+    L anch (EpaComment (EpaBlockComment s) prior) -> addComment s anch prior
+    L _anch (EpaComment (EpaEofComment) _prior) -> pure ()

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

@@ -0,0 +1,256 @@
+{-# 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.Sequence                 as Seq
+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.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
+
+
+
+-- 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 @Bool
+  let
+    wrapNonDeclToBriDoc = MultiRWSS.withMultiReader conf
+      . MultiRWSS.withMultiState_ (CommentCounter 0)
+    FinalList moduleElementsStream = splitModule
+      shouldReformatHead
+      parsedModule
+      (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
+                MEPrettyModuleHead (L loc modHead) -> wrapNonDeclToBriDoc $ do
+                  case modHead of
+                    HsModule epAnn _layoutInfo Nothing Nothing _ _ _ _ -> do
+                      (bd, _) <-
+                        briDocMToPPM
+                        $ maybe id
+                                docFlushRemaining
+                                (srcSpanFileName_maybe loc)
+                        $ docHandleComms epAnn docSeparator
+                      ppBriDoc bd
+                    HsModule _ _layoutInfo Nothing Just{} _ _ _ _ -> error
+                      "brittany internal error: exports without module name"
+                    HsModule epAnn _layoutInfo (Just n) les _ _ _ _ -> do
+                      let startDelta = obtainAnnDeltaPos epAnn GHC.AnnModule
+                      tellDebugMess (show startDelta)
+                      case startDelta of
+                        Nothing         -> pure ()
+                        Just GHC.SameLine{} -> pure ()
+                        Just (GHC.DifferentLine r _) ->
+                          mTell $ TextL.Builder.fromString $ replicate (r - 1) '\n'
+                      (bd, _) <-
+                        briDocMToPPM
+                        $ maybe id
+                                docFlushRemaining
+                                (srcSpanFileName_maybe loc)
+                        $ moduleNameExportBridoc epAnn n les
+                      ppBriDoc bd
+                MEImportDecl importDecl immediateAfterComms ->
+                  wrapNonDeclToBriDoc $ do
+                    (bd, _) <-
+                      briDocMToPPM
+                        $ docSeq
+                            ( layoutImport importDecl
+                            : map commentToDoc immediateAfterComms
+                            )
+                    ppBriDoc bd
+                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{}             -> useTraceFunc traceFunc "MEDecl"
+        MEComment{}          -> useTraceFunc traceFunc "MEComment"
+        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 @Bool
+  bd <- fmap fst $ if exactprintOnly
+    then briDocMToPPM
+      $ docSeq (briDocByExact 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
+        $ docSeq (innerDoc : map commentToDoc immediateAfterComms)
+      if errorCount == 0 then pure (r, 0) else briDocMToPPM $ briDocByExact decl
+  ppBriDoc bd
+  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/DataDecl.hs

@@ -1,81 +1,92 @@
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
-module Language.Haskell.Brittany.Internal.Layouters.DataDecl where
+module Language.Haskell.Brittany.Internal.ToBriDoc.DataDecl where
 
-import qualified Data.Data
-import qualified Data.Semigroup as Semigroup
 import qualified Data.Text as Text
-import GHC (GenLocated(L), Located)
+import GHC (GenLocated(L))
-import qualified GHC
 import GHC.Hs
 import qualified GHC.OldList as List
 import Language.Haskell.Brittany.Internal.Config.Types
-import Language.Haskell.Brittany.Internal.LayouterBasics
+import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
-import Language.Haskell.Brittany.Internal.Layouters.Type
+import Language.Haskell.Brittany.Internal.ToBriDoc.Type
 import Language.Haskell.Brittany.Internal.Prelude
-import Language.Haskell.Brittany.Internal.PreludeUtils
 import Language.Haskell.Brittany.Internal.Types
+import Language.Haskell.Brittany.Internal.Components.BriDoc
 
 
 
 layoutDataDecl
-  :: Located (TyClDecl GhcPs)
+  :: LTyClDecl GhcPs
-  -> Located RdrName
+  -> LIdP GhcPs
   -> LHsQTyVars GhcPs
+  -> [LHsTypeArg GhcPs]
   -> HsDataDefn GhcPs
   -> ToBriDocM BriDocNumbered
-layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
+layoutDataDecl ltycl name (HsQTvs _ bndrs) pats defn = case defn of
   -- newtype MyType a b = MyType ..
-  HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs ->
+  HsDataDefn NoExtField NewType Nothing _ctype Nothing [cons] mDerivs ->
     case cons of
-      (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc))
+      (L _ (ConDeclH98 epAnn consName False _qvars ctxMay details _conDoc)) ->
-        -> docWrapNode ltycl $ do
+        let isSimple = case ctxMay of
-          nameStr <- lrdrNameToTextAnn name
+              Nothing -> True
-          consNameStr <- lrdrNameToTextAnn consName
+              Just (L _ []) -> True
-          tyVarLine <- return <$> createBndrDoc bndrs
+              _ -> False
-          -- headDoc     <- fmap return $ docSeq
+        in if isSimple
-          --   [ appSep $ docLitS "newtype")
+          then do
-          --   , appSep $ docLit nameStr
+            nameStr <- lrdrNameToTextAnn name
-          --   , appSep tyVarLine
+            consNameStr <- lrdrNameToTextAnn consName
-          --   ]
+            tyVarLine <- shareDoc $ createBndrDoc bndrs
-          rhsDoc <- return <$> createDetailsDoc consNameStr details
+            patDocs <- mapM shareDoc $ layoutHsTyPats pats
-          createDerivingPar mDerivs $ docSeq
+            -- headDoc     <- fmap return $ docSeq
-            [ appSep $ docLitS "newtype"
+            --   [ appSep $ docLitS "newtype")
-            , appSep $ docLit nameStr
+            --   , appSep $ docLit nameStr
-            , appSep tyVarLine
+            --   , appSep tyVarLine
-            , docSeparator
+            --   ]
-            , docLitS "="
+            rhsDoc <- return <$> createDetailsDoc consNameStr details
-            , docSeparator
+            createDerivingPar mDerivs $ docSeq
-            , rhsDoc
+              [ appSep $ docLitS "newtype"
-            ]
+              , appSep $ docLit nameStr
+              , appSep tyVarLine
+              , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
+              , docSeparator
+              , docLitS "="
+              , docSeparator
+              , docHandleComms epAnn $ rhsDoc
+              ]
+          else briDocByExactNoComment ltycl
       _ -> briDocByExactNoComment ltycl
 
 
   -- data MyData a b
   -- (zero constructors)
-  HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs ->
+  HsDataDefn NoExtField DataType ctxMay _ctype Nothing [] mDerivs -> do
-    docWrapNode ltycl $ do
+    lhsContextDoc <- case ctxMay of
-      lhsContextDoc <- docSharedWrapper createContextDoc lhsContext
+      Just (L _ lhsContext) -> shareDoc $ createContextDoc lhsContext
-      nameStr <- lrdrNameToTextAnn name
+      Nothing -> pure docEmpty
-      tyVarLine <- return <$> createBndrDoc bndrs
+    nameStr <- lrdrNameToTextAnn name
-      createDerivingPar mDerivs $ docSeq
+    tyVarLine <- return <$> createBndrDoc bndrs
-        [ appSep $ docLitS "data"
+    patDocs <- mapM shareDoc $ layoutHsTyPats pats
-        , lhsContextDoc
+    createDerivingPar mDerivs $ docSeq
-        , appSep $ docLit nameStr
+      [ appSep $ docLitS "data"
-        , appSep tyVarLine
+      , lhsContextDoc
-        ]
+      , appSep $ docLit nameStr
+      , appSep tyVarLine
+      , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
+      ]
 
   -- data MyData = MyData ..
   -- data MyData = MyData { .. }
-  HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs ->
+  HsDataDefn NoExtField DataType ctxMay _ctype Nothing [cons] mDerivs ->
     case cons of
-      (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc))
+      (L _ (ConDeclH98 epAnn consName _hasExt qvars mRhsContext details _conDoc))
-        -> docWrapNode ltycl $ do
+        -> do
-          lhsContextDoc <- docSharedWrapper createContextDoc lhsContext
+          lhsContextDoc <- case ctxMay of
+            Just (L _ lhsContext) -> shareDoc $ createContextDoc lhsContext
+            Nothing -> pure docEmpty
           nameStr <- lrdrNameToTextAnn name
           consNameStr <- lrdrNameToTextAnn consName
           tyVarLine <- return <$> createBndrDoc bndrs
+          patDocs <- mapM shareDoc $ layoutHsTyPats pats
           forallDocMay <- case createForallDoc qvars of
             Nothing -> pure Nothing
             Just x -> Just . pure <$> x
@@ -83,8 +94,11 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
             Nothing -> pure Nothing
             Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt
           rhsDoc <- return <$> createDetailsDoc consNameStr details
+          let posEqual = obtainAnnPos epAnn AnnEqual
           consDoc <-
-            fmap pure
+            shareDoc
+            $ docHandleComms epAnn
+            $ docHandleComms posEqual
             $ docNonBottomSpacing
             $ case (forallDocMay, rhsContextDocMay) of
                 (Just forallDoc, Just rhsContextDoc) -> docLines
@@ -111,14 +125,15 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
           createDerivingPar mDerivs $ docAlt
             [ -- data D = forall a . Show a => D a
               docSeq
-              [ docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq
+              [ -- TOOD92 docNodeAnnKW ltycl (Just GHC.AnnData) $ 
+                docSeq
                 [ appSep $ docLitS "data"
                 , docForceSingleline $ lhsContextDoc
                 , appSep $ docLit nameStr
                 , appSep tyVarLine
-                , docSeparator
+                , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
                 ]
-              , docLitS "="
+              , docHandleComms epAnn $ docHandleComms posEqual $ docLitS "="
               , docSeparator
               , docSetIndentLevel $ docSeq
                 [ case forallDocMay of
@@ -137,15 +152,17 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
             , -- data D
               --   = forall a . Show a => D a
               docAddBaseY BrIndentRegular $ docPar
-              (docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq
+              ( -- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $ 
+                docSeq
                 [ appSep $ docLitS "data"
                 , docForceSingleline lhsContextDoc
                 , appSep $ docLit nameStr
                 , tyVarLine
+                , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
                 ]
               )
               (docSeq
-                [ docLitS "="
+                [ docHandleComms epAnn $ docHandleComms posEqual $ docLitS "="
                 , docSeparator
                 , docSetIndentLevel $ docSeq
                   [ case forallDocMay of
@@ -167,11 +184,13 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
               --   . Show a =>
               --     D a
               docAddBaseY BrIndentRegular $ docPar
-              (docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq
+              ( -- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $ 
+                docSeq
                 [ appSep $ docLitS "data"
                 , docForceSingleline lhsContextDoc
                 , appSep $ docLit nameStr
                 , tyVarLine
+                , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
                 ]
               )
               consDoc
@@ -190,8 +209,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
               (docLitS "data")
               (docLines
                 [ lhsContextDoc
-                , docNodeAnnKW ltycl (Just GHC.AnnData)
+                , -- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $
-                  $ docSeq [appSep $ docLit nameStr, tyVarLine]
+                  docSeq [appSep $ docLit nameStr, tyVarLine, docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]]
                 , consDoc
                 ]
               )
@@ -200,13 +219,23 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
 
   _ -> briDocByExactNoComment ltycl
 
+layoutHsTyPats
+  :: [LHsTypeArg GhcPs] -> [ToBriDocM BriDocNumbered]
+layoutHsTyPats pats = pats <&> \case
+  HsValArg tm -> layoutType tm
+  HsTypeArg _l ty -> docSeq [docLit $ Text.pack "@", layoutType 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.
+  HsArgPar _l -> error "brittany internal error: HsArgPar{}"
+
 createContextDoc :: HsContext GhcPs -> ToBriDocM BriDocNumbered
 createContextDoc [] = docEmpty
 createContextDoc [t] =
   docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator]
 createContextDoc (t1 : tR) = do
-  t1Doc <- docSharedWrapper layoutType t1
+  t1Doc <- shareDoc $ layoutType t1
-  tRDocs <- tR `forM` docSharedWrapper layoutType
+  tRDocs <- tR `forM` (shareDoc . layoutType)
   docAlt
     [ docSeq
       [ docLitS "("
@@ -228,7 +257,7 @@ createBndrDoc bs = do
   tyVarDocs <- bs `forM` \case
     (L _ (UserTyVar _ _ext vname)) -> return $ (lrdrNameToText vname, Nothing)
     (L _ (KindedTyVar _ _ext lrdrName kind)) -> do
-      d <- docSharedWrapper layoutType kind
+      d <- shareDoc $ layoutType kind
       return $ (lrdrNameToText lrdrName, Just $ d)
   docSeq $ List.intersperse docSeparator $ tyVarDocs <&> \(vname, mKind) ->
     case mKind of
@@ -247,57 +276,73 @@ createDerivingPar
   :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
 createDerivingPar derivs mainDoc = do
   case derivs of
-    (L _ []) -> mainDoc
+    [] -> mainDoc
-    (L _ types) ->
+    types ->
       docPar mainDoc
         $ docEnsureIndent BrIndentRegular
         $ docLines
-        $ docWrapNode derivs
+        -- TODO92 $ docWrapNode derivs
         $ derivingClauseDoc
         <$> types
 
 derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered
-derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of
+derivingClauseDoc (L _ (HsDerivingClause epAnn mStrategy types)) =
-  (L _ []) -> docSeq []
+  case types of
-  (L _ ts) ->
+    L _ (DctSingle _ ty) ->
-    let
+      let
-      tsLength = length ts
+        (lhsStrategy, rhsStrategy) =
-      whenMoreThan1Type val = if tsLength > 1 then docLitS val else docLitS ""
+          maybe (docEmpty, docEmpty) strategyLeftRight mStrategy
-      (lhsStrategy, rhsStrategy) =
+      in docSeq
-        maybe (docEmpty, docEmpty) strategyLeftRight mStrategy
+        [ docDeriving
-    in docSeq
+        , docHandleComms types $ lhsStrategy
-      [ docDeriving
+        , docSeparator
-      , docWrapNodePrior types $ lhsStrategy
+        , docHandleListElemComms layoutSigType ty -- TODO92 `docHandleRemaining types` here ?
-      , docSeparator
+          -- \case
-      , whenMoreThan1Type "("
+          --     HsIB _ t -> layoutType t
-      , docWrapNodeRest types
+        , rhsStrategy
-      $ docSeq
+        ]
-      $ List.intersperse docCommaSep
+    (L (SrcSpanAnn _multiEpAnn _) (DctMulti NoExtField [])) -> docSeq []
-      $ ts
+    (L (SrcSpanAnn multiEpAnn _) (DctMulti NoExtField ts)) ->
-      <&> \case
+      let
-            HsIB _ t -> layoutType t
+        tsLength = length ts
-      , whenMoreThan1Type ")"
+        whenMoreThan1Type val = if tsLength > 1 then docLitS val else docLitS ""
-      , rhsStrategy
+        (lhsStrategy, rhsStrategy) =
-      ]
+          maybe (docEmpty, docEmpty) strategyLeftRight mStrategy
+        posClose = case multiEpAnn of
+          EpAnn _ (AnnContext _ _ [s]) _ -> Just $ epaLocationRealSrcSpanStart s
+          _ -> Nothing
+      in docSeq
+        [ docDeriving
+        , docHandleComms types $ lhsStrategy
+        , docSeparator
+        , whenMoreThan1Type "("
+        , docSeq -- TODO92 `docHandleRemaining types` here ?
+        $ List.intersperse docCommaSep
+        $ ts <&> docHandleListElemComms layoutSigType
+        , docHandleComms posClose $ whenMoreThan1Type ")"
+        , rhsStrategy
+        ]
  where
+  posDeriving = obtainAnnPos epAnn AnnDeriving
+  docDeriving = docHandleComms epAnn $ docHandleComms posDeriving $ docLitS "deriving"
   strategyLeftRight = \case
-    (L _ StockStrategy) -> (docLitS " stock", docEmpty)
+    (L _ (StockStrategy _)) -> (docLitS " stock", docEmpty)
-    (L _ AnyclassStrategy) -> (docLitS " anyclass", docEmpty)
+    (L _ (AnyclassStrategy _)) -> (docLitS " anyclass", docEmpty)
-    (L _ NewtypeStrategy) -> (docLitS " newtype", docEmpty)
+    (L _ (NewtypeStrategy _)) -> (docLitS " newtype", docEmpty)
-    lVia@(L _ (ViaStrategy viaTypes)) ->
+    _lVia@(L _ (ViaStrategy (XViaStrategyPs viaEpAnn viaType))) ->
       ( docEmpty
-      , case viaTypes of
+      , docSeq
-        HsIB _ext t ->
+        [ docHandleComms viaEpAnn $ docLitS " via"
-          docSeq [docWrapNode lVia $ docLitS " via", docSeparator, layoutType t]
+        , docSeparator
+        , docHandleListElemComms layoutSigType viaType
+        ]
       )
 
-docDeriving :: ToBriDocM BriDocNumbered
-docDeriving = docLitS "deriving"
 
 createDetailsDoc
-  :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered)
+  :: Text -> HsConDeclH98Details GhcPs -> (ToBriDocM BriDocNumbered)
 createDetailsDoc consNameStr details = case details of
-  PrefixCon args -> do
+  PrefixCon _ args -> do
     indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
     let
       singleLine = docSeq
@@ -331,8 +376,12 @@ createDetailsDoc consNameStr details = case details of
         docAlt [singleLine, multiAppended, multiIndented, leftIndented]
   RecCon (L _ []) ->
     docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"]
-  RecCon lRec@(L _ fields@(_ : _)) -> do
+  RecCon (L (SrcSpanAnn epAnn _) fields@(_ : _)) -> do
-    let ((fName1, fType1) : fDocR) = mkFieldDocs fields
+    let posOpen = obtainAnnPos epAnn AnnOpenC
+    let posClose = obtainAnnPos epAnn AnnCloseC
+    let ((fName1, fType1), fDocR) = case mkFieldDocs fields of
+          (doc1:docR) -> (doc1, docR)
+          _ -> error "cannot happen (TM)"
     -- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack
     let allowSingleline = False
     docAddBaseY BrIndentRegular $ runFilteredAlternative $ do
@@ -340,10 +389,10 @@ createDetailsDoc consNameStr details = case details of
       addAlternativeCond allowSingleline $ docSeq
         [ docLit consNameStr
         , docSeparator
-        , docWrapNodePrior lRec $ docLitS "{"
+        , docHandleComms posOpen $ docLitS "{"
         , docSeparator
-        , docWrapNodeRest lRec
+        , docForceSingleline
-        $ docForceSingleline
+        $ docHandleComms epAnn
         $ docSeq
         $ join
         $ [fName1, docSeparator, docLitS "::", docSeparator, fType1]
@@ -358,28 +407,28 @@ createDetailsDoc consNameStr details = case details of
           | (fName, fType) <- fDocR
           ]
         , docSeparator
-        , docLitS "}"
+        , docHandleComms posClose $ docLitS "}"
         ]
       addAlternative $ docPar
         (docLit consNameStr)
-        (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines
+        (docNonBottomSpacingS $ docLines
           [ docAlt
             [ docCols
               ColRecDecl
-              [ appSep (docLitS "{")
+              [ docHandleComms posOpen $ appSep (docLitS "{")
-              , appSep $ docForceSingleline fName1
+              , docHandleComms epAnn $ appSep $ docForceSingleline fName1
               , docSeq [docLitS "::", docSeparator]
               , docForceSingleline $ fType1
               ]
             , docSeq
-              [ docLitS "{"
+              [ docHandleComms posOpen $ docLitS "{"
               , docSeparator
               , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar
                 fName1
                 (docSeq [docLitS "::", docSeparator, fType1])
               ]
             ]
-          , docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) ->
+          , docLines $ fDocR <&> \(fName, fType) ->
             docAlt
               [ docCols
                 ColRecDecl
@@ -396,7 +445,7 @@ createDetailsDoc consNameStr details = case details of
                   (docSeq [docLitS "::", docSeparator, fType])
                 ]
               ]
-          , docLitS "}"
+          , docHandleComms posClose $ docLitS "}"
           ]
         )
   InfixCon arg1 arg2 -> docSeq
@@ -410,8 +459,7 @@ createDetailsDoc consNameStr details = case details of
   mkFieldDocs
     :: [LConDeclField GhcPs]
     -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)]
-  mkFieldDocs = fmap $ \lField -> case lField of
+  mkFieldDocs = map createNamesAndTypeDoc
-    L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t
 
 createForallDoc
   :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered)
@@ -420,15 +468,19 @@ createForallDoc lhsTyVarBndrs =
   Just $ docSeq [docLitS "forall ", createBndrDoc lhsTyVarBndrs]
 
 createNamesAndTypeDoc
-  :: Data.Data.Data ast
+  :: LConDeclField GhcPs
-  => Located ast
-  -> [GenLocated t (FieldOcc GhcPs)]
-  -> Located (HsType GhcPs)
   -> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)
-createNamesAndTypeDoc lField names t =
+createNamesAndTypeDoc lField@(L _ (ConDeclField epAnn names t _)) =
-  ( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq
+  ( docFlushCommsPost posColon
-    [ docSeq $ List.intersperse docCommaSep $ names <&> \case
+    $ docHandleComms posStart
-        L _ (FieldOcc _ fieldName) -> docLit =<< lrdrNameToTextAnn fieldName
+    $ docHandleComms epAnn
-    ]
+    $ docSeq
-  , docWrapNodeRest lField $ layoutType t
+        [ docSeq $ List.intersperse docCommaSep $ names <&> \case
+            L _ (FieldOcc _ fieldName) ->
+              docLit =<< lrdrNameToTextAnn fieldName
+        ]
+  , docFlushCommsPost posComma (layoutType t)
   )
+ where
+  (posStart, posComma) = obtainListElemStartCommaLocs lField
+  posColon             = obtainAnnPos epAnn AnnDcolon

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

@@ -1,16 +1,15 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 
-module Language.Haskell.Brittany.Internal.Layouters.Expr where
+module Language.Haskell.Brittany.Internal.ToBriDoc.Expr where
 
 import GHC.Hs
 import Language.Haskell.Brittany.Internal.Types
+import Language.Haskell.Brittany.Internal.Components.BriDoc
 
 
 
 layoutExpr :: ToBriDoc HsExpr
 
--- layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
-
 litBriDoc :: HsLit GhcPs -> BriDocFInt
 
 overLitValBriDoc :: OverLitVal -> BriDocFInt

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

@@ -0,0 +1,252 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Language.Haskell.Brittany.Internal.ToBriDoc.IE where
+
+import qualified Data.List.Extra
+import qualified Data.Text                     as Text
+import           GHC                            ( GenLocated(L)
+                                                , ModuleName
+                                                , moduleNameString
+                                                , unLoc
+                                                )
+import           GHC.Hs
+import qualified GHC.OldList                   as List
+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.Types
+import           Language.Haskell.Brittany.Internal.Utils
+
+
+
+prepareName :: LIEWrappedName name -> LocatedN name
+prepareName = ieLWrappedName
+
+layoutIE :: Data.Data.Data ast => ast -> ToBriDoc IE
+layoutIE commAst lie@(L _ ie) = docHandleComms lie $ case ie of
+  IEVar      _ x -> layoutWrapped lie x
+  IEThingAbs _ x -> layoutWrapped lie x
+  IEThingAll _ x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]
+  IEThingWith epAnn x (IEWildcard _) _ -> do
+    let posOpen = obtainAnnPos epAnn AnnOpenP
+    let posClose = obtainAnnPos epAnn AnnCloseP
+    let posDotDot = obtainAnnPos epAnn AnnDotdot
+    docSeq 
+      [ layoutWrapped lie x
+      , docHandleComms posOpen $ docLitS "("
+      , docHandleComms posDotDot $ docLitS ".."
+      , docHandleComms posClose $ docLitS ")"
+      ]
+  IEThingWith epAnn x _ ns -> do
+    let hasComments = or
+          ( hasCommentsBetween commAst posOpen posClose
+          : hasAnyCommentsBelow x
+          : map hasAnyCommentsBelow ns
+          )
+    let sortedNs = List.sortOn wrappedNameToText ns
+    runFilteredAlternative $ do
+      addAlternativeCond (not hasComments)
+        $  docSeq
+        $  [layoutWrapped lie x, docHandleComms posOpen $ docLit $ Text.pack "("]
+        ++ intersperse docCommaSep (map nameDoc sortedNs)
+        ++ [docHandleComms posClose docParenR]
+      addAlternative
+        -- $ docWrapNodeRest lie
+        $ docAddBaseY BrIndentRegular
+        $ docPar (layoutWrapped lie x) (layoutItems (splitFirstLast sortedNs))
+   where
+    posOpen  = obtainAnnPos epAnn AnnOpenP
+    posClose = obtainAnnPos epAnn AnnCloseP
+    nameDoc =  docHandleListElemComms (docLit <=< lrdrNameToTextAnn . prepareName)
+    layoutItem n = docSeq
+      [ docCommaSep
+      , -- TODO92 docWrapNode n $ 
+        nameDoc n
+      ]
+    layoutItems FirstLastEmpty = docSetBaseY $ docLines
+      [ docSeq
+        [ docHandleComms posOpen docParenLSep
+        , -- TODO92 docNodeAnnKW lie (Just AnnOpenP) 
+          docEmpty
+        ]
+      , docHandleComms posClose docParenR
+      ]
+    layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines
+      [ docSeq
+        [ docHandleComms posOpen docParenLSep
+        , -- TODO92 docNodeAnnKW lie (Just AnnOpenP) $ 
+          nameDoc n
+        ]
+      , docHandleComms posClose docParenR
+      ]
+    layoutItems (FirstLast n1 nMs nN) =
+      docSetBaseY
+        $  docLines
+        $  [ docSeq
+               [ docHandleComms posOpen docParenLSep
+               , -- TODO92 docWrapNode n1 $ 
+                 nameDoc n1
+               ]
+           ]
+        ++ map layoutItem nMs
+        ++ [ docSeq
+             [ docCommaSep
+             , -- TODO92 docNodeAnnKW lie (Just AnnOpenP) $ 
+               nameDoc nN
+             ]
+           , docHandleComms posClose docParenR
+           ]
+  IEModuleContents _ n -> docSeq
+    [ docLit $ Text.pack "module"
+    , docSeparator
+    , docLit . Text.pack . moduleNameString $ unLoc n
+    ]
+  _ -> docEmpty
+ where
+  layoutWrapped _ = \case
+    L _ (IEName n       ) -> docLit =<< lrdrNameToTextAnn n
+    L _ (IEPattern loc n) -> do
+      name <- lrdrNameToTextAnn n
+      docHandleComms loc $ docLit $ Text.pack "pattern " <> name
+    L _ (IEType loc n) -> do
+      name <- lrdrNameToTextAnn n
+      docHandleComms loc $ docLit $ Text.pack "type " <> name
+
+data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted
+-- Helper function to deal with Located lists of LIEs.
+-- In particular this will also associate documentation
+-- from the located list that actually belongs to the last IE.
+-- It also adds docCommaSep to all but the first element
+-- This configuration allows both vertical and horizontal
+-- handling of the resulting list. Adding parens is
+-- left to the caller since that is context sensitive
+layoutAnnAndSepLLIEs
+  :: (Data.Data.Data a, HasCallStack)
+  => SortItemsFlag
+  -> a
+  -> [LIE GhcPs]
+  -> ToBriDocM [ToBriDocM BriDocNumbered]
+layoutAnnAndSepLLIEs shouldSort commAst lies = do
+  let makeIENode ie = docSeq [docCommaSep, ie]
+  let sortedLies =
+        [ items
+        | group <- Data.List.Extra.groupOn lieToText
+          $ List.sortOn lieToText lies
+        , items <- mergeGroup group
+        ]
+  let ieDocs = fmap (docHandleListElemComms (layoutIE commAst)) $ case shouldSort of
+        ShouldSortItems   -> sortedLies
+        KeepItemsUnsorted -> lies
+  ieCommaDocs <- sequence $ case splitFirstLast ieDocs of
+    FirstLastEmpty         -> []
+    FirstLastSingleton ie  -> [ie]
+    FirstLast ie1 ieMs ieN -> [ie1] ++ map makeIENode ieMs ++ [makeIENode ieN]
+  pure $ fmap pure ieCommaDocs -- returned shared nodes
+ where
+  mergeGroup :: [LIE GhcPs] -> [LIE GhcPs]
+  mergeGroup []        = []
+  mergeGroup items@[_] = items
+  mergeGroup items     = if
+    | all isProperIEThing items -> [List.foldl1' thingFolder items]
+    | all isIEVar items         -> [List.foldl1' thingFolder items]
+    | otherwise                 -> items
+  -- proper means that if it is a ThingWith, it does not contain a wildcard
+  -- (because I don't know what a wildcard means if it is not already a
+  -- IEThingAll).
+  isProperIEThing :: LIE GhcPs -> Bool
+  isProperIEThing = \case
+    L _ (IEThingAbs _ _wn) -> True
+    L _ (IEThingAll _ _wn) -> True
+    L _ (IEThingWith _ _wn NoIEWildcard _) -> True
+    _ -> False
+  isIEVar :: LIE GhcPs -> Bool
+  isIEVar = \case
+    L _ IEVar{} -> True
+    _           -> False
+  thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs
+  thingFolder l1@(L _ IEVar{}     ) _                     = l1
+  thingFolder l1@(L _ IEThingAll{}) _                     = l1
+  thingFolder _                     l2@(L _ IEThingAll{}) = l2
+  thingFolder l1                    (   L _ IEThingAbs{}) = l1
+  thingFolder (L _ IEThingAbs{})    l2                    = l2
+  thingFolder (L l (IEThingWith x wn _ items1)) (L _ (IEThingWith _ _ _ items2))
+    = L l (IEThingWith x wn NoIEWildcard (items1 ++ items2))
+  thingFolder _ _ =
+    error "thingFolder should be exhaustive because we have a guard above"
+
+
+-- Builds a complete layout for the given located
+-- list of LIEs. The layout provides two alternatives:
+-- (item, item, ..., item)
+-- ( item
+-- , item
+-- ...
+-- , item
+-- )
+-- If the llies contains comments the list will
+-- always expand over multiple lines, even when empty:
+-- () -- no comments
+-- ( -- a comment
+-- )
+layoutLLIEs
+  :: HasCallStack
+  => Bool
+  -> SortItemsFlag
+  -> LocatedL [LIE GhcPs]
+  -> ToBriDocM BriDocNumbered
+layoutLLIEs enableSingleline shouldSort llies@(L epAnn lies) = do
+  let posOpen  = obtainAnnPos epAnn AnnOpenP
+  let posClose = obtainAnnPos epAnn AnnCloseP
+  ieDs <- layoutAnnAndSepLLIEs shouldSort llies lies
+  let hasComments = hasAnyCommentsBelow llies
+  docOpen  <- shareDoc $ docHandleComms posOpen docParenL
+  docClose <- shareDoc $ docHandleComms posClose docParenR
+  docHandleComms llies $ runFilteredAlternative $ case ieDs of
+    [] -> do
+      addAlternativeCond (not hasComments) $ docLit $ Text.pack "()"
+      addAlternativeCond hasComments $ docPar docOpen docClose
+    (ieDsH : ieDsT) -> do
+      addAlternativeCond (not hasComments && enableSingleline)
+        $  docSeq
+        $  [docOpen]
+        ++ (docForceSingleline <$> ieDs)
+        ++ [docClose]
+      addAlternative
+        $  docPar (docSetBaseY $ docSeq [docOpen, docSeparator, ieDsH])
+        $  docLines
+        $  ieDsT
+        ++ [docClose]
+
+-- | Returns a "fingerprint string", not a full text representation, nor even
+-- a source code representation of this syntax node.
+-- Used for sorting, not for printing the formatter's output source code.
+wrappedNameToText :: LIEWrappedName RdrName -> Text
+wrappedNameToText = \case
+  L _ (IEName n        ) -> lrdrNameToText n
+  L _ (IEPattern _loc n) -> lrdrNameToText n
+  L _ (IEType    _loc n) -> lrdrNameToText n
+
+-- | Returns a "fingerprint string", not a full text representation, nor even
+-- a source code representation of this syntax node.
+-- Used for sorting, not for printing the formatter's output source code.
+lieToText :: LIE GhcPs -> Text
+lieToText = \case
+  L _ (IEVar      _ wn     ) -> wrappedNameToText wn
+  L _ (IEThingAbs _ wn     ) -> wrappedNameToText wn
+  L _ (IEThingAll _ wn     ) -> wrappedNameToText wn
+  L _ (IEThingWith _ wn _ _) -> wrappedNameToText wn
+  -- TODO: These _may_ appear in exports!
+  -- Need to check, and either put them at the top (for module) or do some
+  -- other clever thing.
+  L _ (IEModuleContents _ n) -> moduleNameToText n
+  L _ IEGroup{}              -> Text.pack "@IEGroup"
+  L _ IEDoc{}                -> Text.pack "@IEDoc"
+  L _ IEDocNamed{}           -> Text.pack "@IEDocNamed"
+ where
+  moduleNameToText :: LocatedA ModuleName -> Text
+  moduleNameToText (L _ name) =
+    Text.pack ("@IEModuleContents" ++ moduleNameString name)

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

@@ -1,19 +1,23 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 
-module Language.Haskell.Brittany.Internal.Layouters.Import where
+-- TODO92
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+
+module Language.Haskell.Brittany.Internal.ToBriDoc.Import where
 
 import qualified Data.Semigroup as Semigroup
 import qualified Data.Text as Text
 import GHC (GenLocated(L), Located, moduleNameString, unLoc)
 import GHC.Hs
 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.LayouterBasics
+import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
-import Language.Haskell.Brittany.Internal.Layouters.IE
+import Language.Haskell.Brittany.Internal.ToBriDoc.IE
 import Language.Haskell.Brittany.Internal.Prelude
-import Language.Haskell.Brittany.Internal.PreludeUtils
 import Language.Haskell.Brittany.Internal.Types
+import Language.Haskell.Brittany.Internal.Components.BriDoc
 
 
 
@@ -23,11 +27,11 @@ prepPkg rawN = case rawN of
   -- This would be odd to encounter and the
   -- result will most certainly be wrong
   NoSourceText -> ""
-prepModName :: Located e -> e
+prepModName :: LocatedA e -> e
 prepModName = unLoc
 
-layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered
+layoutImport :: LImportDecl GhcPs -> ToBriDocM BriDocNumbered
-layoutImport importD = case importD of
+layoutImport ldecl@(L _ importD) = docHandleComms ldecl $ case importD of
   ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do
     importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack
     importAsCol <-
@@ -75,8 +79,12 @@ layoutImport importD = case importD of
       importHead = docSeq [importQualifiers, modNameD]
       bindingsD = case mllies of
         Nothing -> docEmpty
-        Just (_, llies) -> do
+        Just (_, llies@(L llEpAnn lies)) -> do
-          hasComments <- hasAnyCommentsBelow llies
+          let hasComments = hasAnyCommentsBelow llies
+          let posOpen = obtainAnnPos llEpAnn AnnOpenP
+          let posClose = obtainAnnPos llEpAnn AnnCloseP
+          docOpen <- shareDoc $ docHandleComms posOpen $ docParenLSep
+          docClose <- shareDoc $ docHandleComms posClose $ docParenR
           if compact
             then docAlt
               [ docSeq
@@ -90,48 +98,48 @@ layoutImport importD = case importD of
                 in makeParIfHiding (layoutLLIEs True ShouldSortItems llies)
               ]
             else do
-              ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies
+              ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies lies
-              docWrapNodeRest llies
+              -- TODO92 docWrapNodeRest llies
-                $ docEnsureIndent (BrIndentSpecial hidDocCol)
+              docHandleComms llies $ docEnsureIndent (BrIndentSpecial hidDocCol)
                 $ case ieDs of
                   -- ..[hiding].( )
                     [] -> if hasComments
                       then docPar
                         (docSeq
-                          [hidDoc, docParenLSep, docWrapNode llies docEmpty]
+                          [hidDoc, docOpen, docEmpty]
                         )
                         (docEnsureIndent
                           (BrIndentSpecial hidDocColDiff)
-                          docParenR
+                          docClose
                         )
                       else docSeq
-                        [hidDoc, docParenLSep, docSeparator, docParenR]
+                        [hidDoc, docOpen, docSeparator, docClose]
                     -- ..[hiding].( b )
                     [ieD] -> runFilteredAlternative $ do
                       addAlternativeCond (not hasComments)
                         $ docSeq
                             [ hidDoc
-                            , docParenLSep
+                            , docOpen
                             , docForceSingleline ieD
                             , docSeparator
-                            , docParenR
+                            , docClose
                             ]
                       addAlternative $ docPar
-                        (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD])
+                        (docSeq [hidDoc, docOpen, docNonBottomSpacing ieD])
                         (docEnsureIndent
                           (BrIndentSpecial hidDocColDiff)
-                          docParenR
+                          docClose
                         )
                     -- ..[hiding].( b
                     --            , b'
                     --            )
                     (ieD : ieDs') -> docPar
-                      (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]
+                      (docSeq [hidDoc, docSetBaseY $ docSeq [docOpen, ieD]]
                       )
                       (docEnsureIndent (BrIndentSpecial hidDocColDiff)
                       $ docLines
                       $ ieDs'
-                      ++ [docParenR]
+                      ++ [docClose]
                       )
       makeAsDoc asT =
         docSeq [appSep $ docLit $ Text.pack "as", appSep $ docLit asT]

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

@@ -0,0 +1,60 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Language.Haskell.Brittany.Internal.ToBriDoc.Module where
+
+import qualified Data.Maybe
+import qualified Data.Text                     as Text
+import           GHC                            ( ModuleName
+                                                , moduleNameString
+                                                , unLoc
+                                                )
+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.ToBriDoc.IE
+import           Language.Haskell.Brittany.Internal.Types
+
+
+
+moduleNameExportBridoc
+  :: EpAnn AnnsModule
+  -> LocatedA ModuleName
+  -> Maybe (LocatedL [LIE GhcPs])
+  -> ToBriDocM BriDocNumbered
+moduleNameExportBridoc epAnn modName les = do
+  let posModule  = obtainAnnPos epAnn AnnModule
+  let posWhere   = obtainAnnPos epAnn AnnWhere
+  allowSingleLineExportList <-
+    mAsk <&> _conf_layout .> _lconfig_allowSingleLineExportList .> confUnpack
+  let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les
+  -- the config should not prevent single-line layout when there is no
+  -- export list
+  let tn              = Text.pack $ moduleNameString $ unLoc modName
+  docHandleComms epAnn $ docHandleComms posModule $ runFilteredAlternative $ do
+    addAlternativeCond allowSingleLine $ docSeq
+      [ appSep $ docLit $ Text.pack "module"
+      , appSep $ docLit tn
+      , docForceSingleline $ appSep $ case les of
+        Nothing -> docEmpty
+        Just x  -> layoutLLIEs True KeepItemsUnsorted x
+      , docSeparator
+      , docHandleComms posWhere $ docLit $ Text.pack "where"
+      ]
+    addAlternative $ docLines
+      [ docAddBaseY BrIndentRegular $ docPar
+          (docSeq
+            [appSep $ docLit $ Text.pack "module", docLit tn]
+          )
+          (docSeq
+            [ case les of
+              Nothing -> docEmpty
+              Just x  -> layoutLLIEs False KeepItemsUnsorted x
+            , docSeparator
+            , docHandleComms posWhere $ docLit $ Text.pack "where"
+            ]
+          )
+      ]
+

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

@@ -1,7 +1,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
-module Language.Haskell.Brittany.Internal.Layouters.Pattern where
+module Language.Haskell.Brittany.Internal.ToBriDoc.Pattern where
 
 import qualified Data.Foldable as Foldable
 import qualified Data.Sequence as Seq
@@ -10,12 +10,12 @@ import GHC (GenLocated(L), ol_val)
 import GHC.Hs
 import qualified GHC.OldList as List
 import GHC.Types.Basic
-import Language.Haskell.Brittany.Internal.LayouterBasics
+import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
-import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr
+import {-# SOURCE #-} Language.Haskell.Brittany.Internal.ToBriDoc.Expr
-import Language.Haskell.Brittany.Internal.Layouters.Type
+import Language.Haskell.Brittany.Internal.ToBriDoc.Type
 import Language.Haskell.Brittany.Internal.Prelude
-import Language.Haskell.Brittany.Internal.PreludeUtils
 import Language.Haskell.Brittany.Internal.Types
+import Language.Haskell.Brittany.Internal.Components.BriDoc
 
 
 
@@ -30,7 +30,7 @@ import Language.Haskell.Brittany.Internal.Types
 -- We will use `case .. of` as the imagined prefix to the examples used in
 -- the different cases below.
 layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered)
-layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
+layoutPat lpat@(L _ pat) = docHandleComms lpat $ case pat of
   WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_"
     -- _ -> expr
   VarPat _ n -> fmap Seq.singleton $ docLit $ lrdrNameToText n
@@ -57,7 +57,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
     --       x1' <- docSeq [docLit $ Text.pack "(", return x1]
     --       xN' <- docSeq [return xN, docLit $ Text.pack ")"]
     --       return $ (x1' Seq.<| middle) Seq.|> xN'
-  ConPat _ lname (PrefixCon args) -> do
+  ConPat _ lname (PrefixCon _tyargs args) -> do -- TODO92 is it safe to ignore tyargs??
     -- Abc a b c -> expr
     nameDoc <- lrdrNameToTextAnn lname
     argDocs <- layoutPat `mapM` args
@@ -84,11 +84,11 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
     -- Abc { a = locA, b = locB, c = locC } -> expr1
     -- Abc { a, b, c } -> expr2
     let t = lrdrNameToText lname
-    fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do
+    fds <- fs `forM` \(L _ (HsRecField _ (L _ fieldOcc) fPat pun)) -> do
       let FieldOcc _ lnameF = fieldOcc
       fExpDoc <- if pun
         then return Nothing
-        else Just <$> docSharedWrapper layoutPat fPat
+        else fmap Just $ shareDoc $ layoutPat fPat
       return (lrdrNameToText lnameF, fExpDoc)
     Seq.singleton <$> docSeq
       [ appSep $ docLit t
@@ -111,11 +111,11 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
     | dotdoti == length fs -> do
     -- Abc { a = locA, .. }
       let t = lrdrNameToText lname
-      fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do
+      fds <- fs `forM` \(L _ (HsRecField _ (L _ fieldOcc) fPat pun)) -> do
         let FieldOcc _ lnameF = fieldOcc
         fExpDoc <- if pun
           then return Nothing
-          else Just <$> docSharedWrapper layoutPat fPat
+          else Just <$> shareDoc (layoutPat fPat)
         return (lrdrNameToText lnameF, fExpDoc)
       Seq.singleton <$> docSeq
         [ appSep $ docLit t
@@ -142,7 +142,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
   SigPat _ pat1 (HsPS _ ty1) -> do
     -- i :: Int -> expr
     patDocs <- layoutPat pat1
-    tyDoc <- docSharedWrapper layoutType ty1
+    tyDoc <- shareDoc $ layoutType ty1
     case Seq.viewr patDocs of
       Seq.EmptyR -> error "cannot happen ljoiuxoasdcoviuasd"
       xR Seq.:> xN -> do
@@ -169,13 +169,22 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
   LazyPat _ pat1 -> do
     -- ~nestedpat -> expr
     wrapPatPrepend pat1 (docLit $ Text.pack "~")
-  NPat _ llit@(L _ ol) mNegative _ -> do
+  NPat _ _llit@(L _ ol) mNegative _ -> do
     -- -13 -> expr
-    litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol
+    -- TODO92 we had `docWrapNode llit` below, but I don't think that is
+    --        necessary/possible any longer..
+    litDoc <- allocateNode $ overLitValBriDoc $ GHC.ol_val ol
     negDoc <- docLit $ Text.pack "-"
     pure $ case mNegative of
       Just{} -> Seq.fromList [negDoc, litDoc]
       Nothing -> Seq.singleton litDoc
+  ViewPat epAnn pat1 pat2 -> do
+    pat1Doc <- docHandleComms epAnn $ layoutExpr pat1
+    let arrowLoc = obtainAnnPos epAnn AnnRarrow
+    pat1DocC <- appSep $ pure pat1Doc
+    pat2Docs <- layoutPat pat2
+    arrowDoc <- docHandleComms arrowLoc $ appSep $ docLitS "->"
+    pure $ pat1DocC Seq.<| arrowDoc Seq.<| pat2Docs
   
   _ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat
 

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

@@ -2,34 +2,36 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
-module Language.Haskell.Brittany.Internal.Layouters.Stmt where
+module Language.Haskell.Brittany.Internal.ToBriDoc.Stmt where
 
-import qualified Data.Semigroup as Semigroup
 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.LayouterBasics
+import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
-import Language.Haskell.Brittany.Internal.Layouters.Decl
+import Language.Haskell.Brittany.Internal.ToBriDoc.Decl
-import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr
+import {-# SOURCE #-} Language.Haskell.Brittany.Internal.ToBriDoc.Expr
-import Language.Haskell.Brittany.Internal.Layouters.Pattern
+import Language.Haskell.Brittany.Internal.ToBriDoc.Pattern
 import Language.Haskell.Brittany.Internal.Prelude
-import Language.Haskell.Brittany.Internal.PreludeUtils
 import Language.Haskell.Brittany.Internal.Types
+import Language.Haskell.Brittany.Internal.Components.BriDoc
 
 
 
-layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
+layoutStmt :: GuardLStmt GhcPs -> ToBriDocM BriDocNumbered
 layoutStmt lstmt@(L _ stmt) = do
   indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
   indentAmount :: Int <-
     mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
-  docWrapNode lstmt $ case stmt of
+  case stmt of
-    LastStmt _ body Nothing _ -> do
+    LastStmt NoExtField body Nothing _ -> do
-      layoutExpr body
+      -- at least the "|" of a monadcomprehension for _some_ reason
-    BindStmt _ lPat expr -> do
+      -- is connected to the _body_ of the "result" stmt. So we need
+      -- to docHandleListElemComms here..
+      docHandleListElemComms layoutExpr body
+    BindStmt epAnn lPat expr -> docHandleComms epAnn $ do
       patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat
-      expDoc <- docSharedWrapper layoutExpr expr
+      expDoc <- shareDoc $ layoutExpr expr
       docAlt
         [ docCols
           ColBindStmt
@@ -46,14 +48,14 @@ layoutStmt lstmt@(L _ stmt) = do
             $ docPar (docLit $ Text.pack "<-") (expDoc)
           ]
         ]
-    LetStmt _ binds -> do
+    LetStmt epAnn binds -> docHandleComms epAnn $ do
       let isFree = indentPolicy == IndentPolicyFree
       let indentFourPlus = indentAmount >= 4
       layoutLocalBinds binds >>= \case
         Nothing -> docLit $ Text.pack "let"
           -- i just tested the above, and it is indeed allowed. heh.
-        Just [] -> docLit $ Text.pack "let" -- this probably never happens
+        Just (_, []) -> docLit $ Text.pack "let" -- this probably never happens
-        Just [bindDoc] -> docAlt
+        Just (_, [bindDoc]) -> docAlt
           [ -- let bind = expr
             docCols
             ColDoLet
@@ -73,7 +75,7 @@ layoutStmt lstmt@(L _ stmt) = do
             (docLit $ Text.pack "let")
             (docSetBaseAndIndent $ return bindDoc)
           ]
-        Just bindDocs -> runFilteredAlternative $ do
+        Just (_, bindDocs) -> runFilteredAlternative $ do
           -- let aaa = expra
           --     bbb = exprb
           --     ccc = exprc
@@ -94,23 +96,24 @@ layoutStmt lstmt@(L _ stmt) = do
             $ docPar
                 (docLit $ Text.pack "let")
                 (docSetBaseAndIndent $ docLines $ return <$> bindDocs)
-    RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do
+    RecStmt epAnn (L _ stmts) _ _ _ _ _ ->
-      -- rec stmt1
+      docHandleComms epAnn $ runFilteredAlternative $ do
-      --     stmt2
+        -- rec stmt1
-      --     stmt3
+        --     stmt2
-      addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq
+        --     stmt3
-        [ docLit (Text.pack "rec")
+        addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq
-        , docSeparator
+          [ docLit (Text.pack "rec")
-        , docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts
+          , docSeparator
-        ]
+          , docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts
-      -- rec
+          ]
-      --   stmt1
+        -- rec
-      --   stmt2
+        --   stmt1
-      --   stmt3
+        --   stmt2
-      addAlternative $ docAddBaseY BrIndentRegular $ docPar
+        --   stmt3
-        (docLit (Text.pack "rec"))
+        addAlternative $ docAddBaseY BrIndentRegular $ docPar
-        (docLines $ layoutStmt <$> stmts)
+          (docLit (Text.pack "rec"))
-    BodyStmt _ expr _ _ -> do
+          (docLines $ layoutStmt <$> stmts)
-      expDoc <- docSharedWrapper layoutExpr expr
+    BodyStmt NoExtField expr _ _ -> do
+      expDoc <- shareDoc $ layoutExpr expr
       docAddBaseY BrIndentRegular $ expDoc
     _ -> briDocByExactInlineOnly "some unknown statement" lstmt

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

@@ -0,0 +1,11 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Language.Haskell.Brittany.Internal.ToBriDoc.Stmt where
+
+import GHC.Hs
+import Language.Haskell.Brittany.Internal.Types
+import Language.Haskell.Brittany.Internal.Components.BriDoc
+
+
+
+layoutStmt :: GuardLStmt GhcPs -> ToBriDocM BriDocNumbered

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

@@ -0,0 +1,535 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Language.Haskell.Brittany.Internal.ToBriDoc.Type where
+
+import qualified Data.Text as Text
+import GHC (GenLocated(L))
+import GHC.Hs
+import GHC.Types.Var(Specificity)
+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 Language.Haskell.Brittany.Internal.Prelude
+import Language.Haskell.Brittany.Internal.Types
+import Language.Haskell.Brittany.Internal.Components.BriDoc
+import Language.Haskell.Brittany.Internal.Utils
+  (FirstLastView(..), splitFirstLast)
+
+
+
+layoutSigType :: ToBriDoc HsSigType
+-- TODO92 we ignore an ann here
+layoutSigType (L _ (HsSig _ outerVarBind typ)) = case outerVarBind of
+  HsOuterImplicit _ -> layoutType typ
+  HsOuterExplicit _ bndrs -> do
+    parts <- splitHsForallTypeFromBinders (map withoutSpecificity bndrs) typ
+    joinSplitArrowType (hasAnyCommentsBelow typ) parts
+
+splitArrowType
+  :: LHsType GhcPs
+  -> ToBriDocM
+       (ToBriDocM BriDocNumbered, [(String, ToBriDocM BriDocNumbered)])
+splitArrowType ltype@(L _ typ) = case typ of
+  HsForAllTy NoExtField hsf typ1 ->
+    splitHsForallTypeFromBinders (getBinders hsf) typ1
+  HsQualTy NoExtField ctxMay typ1 -> do
+    (innerHead, innerBody) <- splitArrowType typ1
+    pure
+      $ ( do
+          cntxtDocs <- case ctxMay of
+            Nothing         -> pure []
+            Just (L _ ctxs) -> ctxs `forM` (shareDoc . layoutType)
+          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)
+        )
+  HsFunTy epAnn _ typ1 typ2 -> do
+    (typ1Doc, (innerHead, innerBody)) <- do
+      let
+        wrapper = case epAnn of
+          EpAnn _ AddSemiAnn{} _ ->
+            error "brittany internal error: HsFunTy EpAnn"
+          EpAnn _ AddCommaAnn{} _ ->
+            error "brittany internal error: HsFunTy EpAnn"
+          EpAnn _ AddVbarAnn{} _ ->
+            error "brittany internal error: HsFunTy EpAnn"
+          EpAnn _ (AddRarrowAnn loc) _ ->
+            docFlushCommsPost (Just $ epaLocationRealSrcSpanStart loc)
+          EpAnn _ AddRarrowAnnU{} _ ->
+            error "brittany internal error: HsFunTy EpAnn"
+          EpAnn _ AddLollyAnnU{} _ ->
+            error "brittany internal error: HsFunTy EpAnn"
+          EpAnnNotUsed -> id
+      typ1Doc   <- docHandleComms epAnn $ wrapper $ layoutType typ1
+      typ2Tuple <- splitArrowType typ2
+      pure (typ1Doc, typ2Tuple)
+    pure $ (pure typ1Doc, ("->", innerHead) : innerBody)
+  _ -> pure (layoutType ltype, [])
+
+splitHsForallTypeFromBinders
+  :: [LHsTyVarBndr () GhcPs]
+  -> LHsType GhcPs
+  -> ToBriDocM
+       (ToBriDocM BriDocNumbered, [(String, ToBriDocM BriDocNumbered)])
+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
+      ]
+
+layoutType :: ToBriDoc HsType
+layoutType ltype@(L _ typ) = docHandleComms ltype $ case typ of
+  -- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible"
+  HsTyVar epAnn promoted name -> docHandleComms epAnn $ do
+    t <- lrdrNameToTextAnnTypeEqualityIsSpecial name
+    case promoted of
+      IsPromoted -> docSeq [docSeparator, docTick, docHandleComms name $ docLit t]
+      NotPromoted -> docHandleComms name $ docLit t
+  HsForAllTy{} -> do
+    parts <- splitArrowType ltype
+    joinSplitArrowType (hasAnyCommentsBelow typ) parts
+  HsQualTy{} -> do
+    parts <- splitArrowType ltype
+    joinSplitArrowType (hasAnyCommentsBelow typ) parts
+  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 ")")
+      ]
+  HsAppTy NoExtField typ1@(L _ HsAppTy{}) typ2 -> do
+    let
+      gather
+        :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs])
+      gather list = \case
+        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
+    docAlt
+      [ docSeq
+      $ docForceSingleline docHead
+      : (docRest >>= \d -> [docSeparator, docForceSingleline d])
+      , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest)
+      ]
+  HsAppTy NoExtField typ1 typ2 -> do
+    typeDoc1 <- shareDoc $ layoutType typ1
+    typeDoc2 <- shareDoc $ layoutType typ2
+    docAlt
+      [ docSeq
+        [docForceSingleline typeDoc1, docSeparator, docForceSingleline typeDoc2]
+      , docPar typeDoc1 (docEnsureIndent BrIndentRegular typeDoc2)
+      ]
+  HsListTy 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 $ docLit $ Text.pack "[ "
+          , docAddBaseY (BrIndentSpecial 2) $ typeDoc1
+          ]
+        )
+        (wrapClose $ docLit $ Text.pack "]")
+      ]
+  HsTupleTy epAnn tupleSort typs -> docHandleComms epAnn $ case tupleSort of
+    HsUnboxedTuple -> unboxed
+    HsBoxedOrConstraintTuple -> simple
+   where
+    unboxed = if null typs
+      then error "brittany internal error: unboxed unit"
+      else docWith docParenHashLSep docParenHashRSep
+    simple = if null typs
+      then unitL
+      else docWith (docLit (Text.pack "(")) (docLit (Text.pack ")"))
+    unitL = docLit $ Text.pack "()"
+    AnnParen _ open close = anns epAnn
+    wrapStart = docHandleComms open
+    wrapEnd   = docHandleComms close
+    docWith start end = do
+      typDocs <- typs `forM` \ty -> do
+        shareDoc $ docHandleListElemComms layoutType ty
+      let
+        line1 = docCols ColTyOpPrefix [wrapStart $ appSep start, head typDocs]
+        lines =
+          List.tail typDocs
+            <&> \d -> docAddBaseY (BrIndentSpecial 2)
+                  $ docCols ColTyOpPrefix [docCommaSep, d]
+        commaDocs = List.intersperse docCommaSep (docForceSingleline <$> typDocs)
+      docAlt
+        [ docSeq
+        $ [wrapStart start]
+        ++ commaDocs
+        ++ [wrapEnd end]
+        , docPar
+            (docAddBaseY (BrIndentSpecial 2) line1)
+            (docLines $ lines ++ [wrapEnd end])
+        ]
+  HsOpTy{} -> -- TODO
+    briDocByExactInlineOnly "HsOpTy{}" ltype
+  -- 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
+  --   --       parse result for any type level operators.
+  --   --       need to check how things are handled on the expression level.
+  --   let opStr = lrdrNameToText opName
+  --   let opLen = Text.length opStr
+  --   layouter1@(Layouter desc1 _ _) <- layoutType typ1
+  --   layouter2@(Layouter desc2 _ _) <- layoutType typ2
+  --   let line = do -- Maybe
+  --         l1 <- _ldesc_line desc1
+  --         l2 <- _ldesc_line desc2
+  --         let len1 = _lColumns_min l1
+  --         let len2 = _lColumns_min l2
+  --         let len = 2 + opLen + len1 + len2
+  --         return $ LayoutColumns
+  --           { _lColumns_key = ColumnKeyUnique
+  --           , _lColumns_lengths = [len]
+  --           , _lColumns_min = len
+  --           }
+  --   let block = do -- Maybe
+  --         rol1 <- descToBlockStart desc1
+  --         (min2, max2) <- descToMinMax (1+opLen) desc2
+  --         let (minR, maxR) = case descToBlockMinMax desc1 of
+  --               Nothing -> (min2, max2)
+  --               Just (min1, max1) -> (max min1 min2, max max1 max2)
+  --         return $ BlockDesc
+  --           { _bdesc_blockStart = rol1
+  --           , _bdesc_min = minR
+  --           , _bdesc_max = maxR
+  --           , _bdesc_opIndentFloatUp = Just (1+opLen)
+  --           }
+  --   return $ Layouter
+  --     { _layouter_desc = LayoutDesc
+  --       { _ldesc_line = line
+  --       , _ldesc_block = block
+  --       }
+  --     , _layouter_func = \params -> do
+  --         remaining <- getCurRemaining
+  --         let allowSameLine = _params_sepLines params /= SepLineTypeOp
+  --         case line of
+  --           Just (LayoutColumns _ _ m) | m <= remaining && allowSameLine -> do
+  --             applyLayouterRestore layouter1 defaultParams
+  --             layoutWriteAppend $ Text.pack " " <> opStr <> Text.pack " "
+  --             applyLayouterRestore layouter2 defaultParams
+  --           _ -> do
+  --             let upIndent   = maybe (1+opLen) (max (1+opLen)) $ _params_opIndent params
+  --             let downIndent = maybe upIndent (max upIndent) $ _bdesc_opIndentFloatUp =<< _ldesc_block desc2
+  --             layoutWithAddIndentN downIndent $ applyLayouterRestore layouter1 defaultParams
+  --             layoutWriteNewline
+  --             layoutWriteAppend $ opStr <> Text.pack " "
+  --             layoutWriteEnsureBlockPlusN downIndent
+  --             applyLayouterRestore layouter2 defaultParams
+  --               { _params_sepLines = SepLineTypeOp
+  --               , _params_opIndent = Just downIndent
+  --               }
+  --     , _layouter_ast = ltype
+  --     }
+  HsIParamTy epAnn (L _ (HsIPName ipName)) typ1 -> do
+    let posColon = obtainAnnPos epAnn AnnDcolon
+    typeDoc1 <- shareDoc $ layoutType typ1
+    docHandleComms epAnn $ docAlt
+      [ docSeq
+        [ docLitS $ "?" ++ showSDocUnsafe (ftext ipName)
+        , docHandleComms posColon $ docLitS "::"
+        , docForceSingleline typeDoc1
+        ]
+      , docPar
+        (docLit $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName)))
+        (docCols
+          ColTyOpPrefix
+          [ docHandleComms posColon $ docLit $ Text.pack ":: "
+          , docAddBaseY (BrIndentSpecial 2) typeDoc1
+          ]
+        )
+      ]
+  -- TODO: test KindSig
+  HsKindSig epAnn typ1 kind1 -> do
+    let posColon = obtainAnnPos epAnn AnnDcolon
+    typeDoc1 <- shareDoc $ layoutType typ1
+    kindDoc1 <- shareDoc $ layoutType kind1
+    docAlt
+      [ docSeq
+          [ docForceSingleline typeDoc1
+          , docSeparator
+          , docHandleComms posColon $ docLit $ Text.pack "::"
+          , docSeparator
+          , docForceSingleline kindDoc1
+          ]
+      , docPar
+          typeDoc1
+          (docCols
+            ColTyOpPrefix
+            [ docHandleComms posColon $ docLit $ Text.pack ":: "
+            , docAddBaseY (BrIndentSpecial 3) kindDoc1
+            ]
+          )
+      ]
+  HsBangTy{} -> -- TODO
+    briDocByExactInlineOnly "HsBangTy{}" ltype
+  -- HsBangTy bang typ1 -> do
+  --   let bangStr = case bang of
+  --         HsSrcBang _ unpackness strictness ->
+  --           (++)
+  --             (case unpackness of
+  --               SrcUnpack   -> "{-# UNPACK #-} "
+  --               SrcNoUnpack -> "{-# NOUNPACK #-} "
+  --               NoSrcUnpack -> ""
+  --             )
+  --             (case strictness of
+  --               SrcLazy     -> "~"
+  --               SrcStrict   -> "!"
+  --               NoSrcStrict -> ""
+  --             )
+  --   let bangLen = length bangStr
+  --   layouter@(Layouter desc _ _) <- layoutType typ1
+  --   let line = do -- Maybe
+  --         l <- _ldesc_line desc
+  --         let len = bangLen + _lColumns_min l
+  --         return $ LayoutColumns
+  --           { _lColumns_key = ColumnKeyUnique
+  --           , _lColumns_lengths = [len]
+  --           , _lColumns_min = len
+  --           }
+  --   let block = do -- Maybe
+  --         rol <- descToBlockStart desc
+  --         (minR,maxR) <- descToBlockMinMax desc
+  --         return $ BlockDesc
+  --           { _bdesc_blockStart = rol
+  --           , _bdesc_min = minR
+  --           , _bdesc_max = maxR
+  --           , _bdesc_opIndentFloatUp = Nothing
+  --           }
+  --   return $ Layouter
+  --     { _layouter_desc = LayoutDesc
+  --       { _ldesc_line = line
+  --       , _ldesc_block = block
+  --       }
+  --     , _layouter_func = \_params -> do
+  --         remaining <- getCurRemaining
+  --         case line of
+  --           Just (LayoutColumns _ _ m) | m <= remaining -> do
+  --             layoutWriteAppend $ Text.pack $ bangStr
+  --             applyLayouterRestore layouter defaultParams
+  --           _ -> do
+  --             layoutWriteAppend $ Text.pack $ bangStr
+  --             layoutWritePostCommentsRestore ltype
+  --             applyLayouterRestore layouter defaultParams
+  --     , _layouter_ast = ltype
+  --     }
+  HsSpliceTy{} -> -- TODO
+    briDocByExactInlineOnly "HsSpliceTy{}" ltype
+  HsDocTy{} -> -- TODO
+    briDocByExactInlineOnly "HsDocTy{}" ltype
+  HsRecTy{} -> -- TODO
+    briDocByExactInlineOnly "HsRecTy{}" ltype
+  HsExplicitListTy epAnn _ typs -> docHandleComms epAnn $ do
+    typDocs <- typs `forM` (shareDoc . docHandleListElemComms layoutType)
+    let hasComments = hasAnyCommentsBelow ltype
+    let specialCommaSep = appSep $ docLit $ Text.pack " ,"
+    docAlt
+      [ docSeq
+      $ [docLit $ Text.pack "'["]
+      ++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs)
+      ++ [docLit $ Text.pack "]"]
+      , case splitFirstLast typDocs of
+        FirstLastEmpty -> docSeq
+          [ docLit $ Text.pack "'[]" -- TODO92 comments AnnOpenS
+          ]
+        FirstLastSingleton e -> docAlt
+          [ docSeq
+            [ docLit $ Text.pack "'["
+            , docForceSingleline e -- TODO92 comments AnnOpenS
+            , docLit $ Text.pack "]"
+            ]
+          , docSetBaseY $ docLines
+            [ docSeq
+              [ docLit $ Text.pack "'["
+              , docSeparator
+              , docSetBaseY $ e -- TODO92 comments AnnOpenS
+              ]
+            , docLit $ Text.pack " ]"
+            ]
+          ]
+        FirstLast e1 ems eN -> runFilteredAlternative $ do
+          addAlternativeCond (not hasComments)
+            $ docSeq
+            $ [docLit $ Text.pack "'["]
+            ++ List.intersperse
+                 specialCommaSep
+                 (docForceSingleline
+                 <$> (e1 : ems ++ [eN]) -- TODO92 comments AnnOpenS
+                 )
+            ++ [docLit $ Text.pack " ]"]
+          addAlternative
+            $ let
+                start = docCols ColList [appSep $ docLit $ Text.pack "'[", e1]
+                linesM = ems <&> \d -> docCols ColList [specialCommaSep, d]
+                lineN = docCols
+                  ColList
+                  [specialCommaSep, eN] -- TODO92 comments AnnOpenS
+                end = docLit $ Text.pack " ]"
+              in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]
+      ]
+  HsExplicitTupleTy{} -> -- TODO
+    briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype
+  HsTyLit _ lit -> case lit of
+    HsNumTy (SourceText srctext) _ -> docLit $ Text.pack srctext
+    HsNumTy NoSourceText _ ->
+      error "overLitValBriDoc: literal with no SourceText"
+    HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext
+    HsStrTy NoSourceText _ ->
+      error "overLitValBriDoc: literal with no SourceText"
+    HsCharTy (SourceText srctext) _ -> docLit $ Text.pack srctext
+    HsCharTy NoSourceText _ ->
+      error "overLitValBriDoc: literal with no SourceText"
+  HsWildCardTy _ -> docLit $ Text.pack "_"
+  HsSumTy{} -> -- TODO
+    briDocByExactInlineOnly "HsSumTy{}" ltype
+  HsStarTy _ isUnicode -> do
+    if isUnicode
+      then docLit $ Text.pack "\x2605" -- Unicode star
+      else docLit $ Text.pack "*"
+  XHsType{} -> error "brittany internal error: XHsType"
+  HsAppKindTy _ ty kind -> do
+    t <- shareDoc $ layoutType ty
+    k <- shareDoc $ layoutType kind
+    docAlt
+      [ docSeq
+        [ docForceSingleline t
+        , docSeparator
+        , docLit $ Text.pack "@"
+        , docForceSingleline k
+        ]
+      , docPar t (docSeq [docLit $ Text.pack "@", k])
+      ]
+
+
+layoutTyVarBndrs
+  :: [LHsTyVarBndr () GhcPs]
+  -> ToBriDocM [(Text, Maybe (ToBriDocM BriDocNumbered))]
+layoutTyVarBndrs = mapM $ \case
+  (L _ (UserTyVar _ _ name)) -> return $ (lrdrNameToText name, Nothing)
+  (L _ (KindedTyVar _ _ lrdrName kind)) -> do
+    d <- shareDoc $ layoutType kind
+    return $ (lrdrNameToText lrdrName, Just $ d)
+
+-- there is no specific reason this returns a list instead of a single
+-- BriDoc node.
+processTyVarBndrsSingleline
+  :: [(Text, Maybe (ToBriDocM BriDocNumbered))] -> [ToBriDocM BriDocNumbered]
+processTyVarBndrsSingleline bndrDocs = bndrDocs >>= \case
+  (tname, Nothing) -> [docSeparator, docLit tname]
+  (tname, Just doc) ->
+    [ docSeparator
+    , docLit $ Text.pack "(" <> tname <> Text.pack " :: "
+    , docForceSingleline $ doc
+    , docLit $ Text.pack ")"
+    ]
+
+getBinders :: HsForAllTelescope GhcPs -> [LHsTyVarBndr () GhcPs]
+getBinders x = case x of
+  HsForAllVis _ b -> b
+  HsForAllInvis _ b -> fmap withoutSpecificity b
+
+withoutSpecificity :: LHsTyVarBndr GHC.Types.Var.Specificity GhcPs -> LHsTyVarBndr () GhcPs
+withoutSpecificity = fmap $ \case
+  UserTyVar a _ c -> UserTyVar a () c
+  KindedTyVar a _ c d -> KindedTyVar a () c d

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

@@ -1,29 +1,55 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MonadComprehensions #-}
 {-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
-module Language.Haskell.Brittany.Internal.Transformations.Alt where
+module Language.Haskell.Brittany.Internal.Transformations.T1_Alt where
 
 import qualified Control.Monad.Memo as Memo
 import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
 import Data.HList.ContainsType
 import qualified Data.List.Extra
-import qualified Data.Semigroup as Semigroup
 import qualified Data.Text as Text
 import qualified GHC.OldList as List
+import qualified Data.Strict.Maybe as Strict
+
 import Language.Haskell.Brittany.Internal.Config.Types
 import Language.Haskell.Brittany.Internal.Prelude
-import Language.Haskell.Brittany.Internal.PreludeUtils
+import Language.Haskell.Brittany.Internal.Components.BriDoc
-import Language.Haskell.Brittany.Internal.Types
+-- import Language.Haskell.Brittany.Internal.Utils
-import Language.Haskell.Brittany.Internal.Utils
 
 
 
+data VerticalSpacingPar
+  = VerticalSpacingParNone -- no indented lines
+  | VerticalSpacingParSome   Int -- indented lines, requiring this much
+                                 -- vertical space at most
+  | VerticalSpacingParAlways Int -- indented lines, requiring this much
+                                 -- vertical space at most, but should
+                                 -- be considered as having space for
+                                 -- any spacing validity check.
+    -- TODO: it might be wrong not to extend "always" to the none case, i.e.
+    -- we might get better properties of spacing operators by having a
+    -- product like (Normal|Always, None|Some Int).
+  deriving (Eq, Show)
+
+data VerticalSpacing
+  = VerticalSpacing
+    { _vs_sameLine  :: !Int
+    , _vs_paragraph :: !VerticalSpacingPar
+    , _vs_parFlag   :: !Bool
+    }
+  deriving (Eq, Show)
+
+newtype LineModeValidity a = LineModeValidity (Strict.Maybe a)
+  deriving (Functor, Applicative, Monad, Show, Alternative)
+
+pattern LineModeValid :: forall t. t -> LineModeValidity t
+pattern LineModeValid x = LineModeValidity (Strict.Just x) :: LineModeValidity t
+pattern LineModeInvalid :: forall t. LineModeValidity t
+pattern LineModeInvalid = LineModeValidity Strict.Nothing :: LineModeValidity t
+
 data AltCurPos = AltCurPos
   { _acp_line :: Int -- chars in the current line
   , _acp_indent :: Int -- current indentation level
@@ -108,7 +134,7 @@ transformAlts =
     --         BDForwardLineMode bd    -> BDFForwardLineMode <$> go bd
     --         BDExternal k ks c t         -> return $ BDFExternal k ks c t
     --         BDAnnotationPrior annKey bd -> BDFAnnotationPrior annKey <$> go bd
-    --         BDAnnotationPost  annKey bd -> BDFAnnotationRest  annKey <$> go bd
+    --         BDAnnotationPost  annKey bd -> BDFAnnotationPost  annKey <$> go bd
     --         BDLines lines         -> BDFLines <$> go `mapM` lines
     --         BDEnsureIndent ind bd -> BDFEnsureIndent ind <$> go bd
     --         BDProhibitMTEL bd     -> BDFProhibitMTEL <$> go bd
@@ -267,18 +293,18 @@ transformAlts =
         return $ x
       BDFExternal{} -> processSpacingSimple bdX $> bdX
       BDFPlain{} -> processSpacingSimple bdX $> bdX
-      BDFAnnotationPrior annKey bd -> do
+      BDFQueueComments comms bd ->
-        acp <- mGet
+        reWrap . BDFQueueComments comms <$> rec bd
-        mSet
+      BDFFlushCommentsPrior loc bd ->
-          $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp }
+        -- TODO92 for AnnotationPrior we had this here:
-        bd' <- rec bd
+        -- > acp <- mGet
-        return $ reWrap $ BDFAnnotationPrior annKey bd'
+        -- > mSet
-      BDFAnnotationRest annKey bd ->
+        -- >   $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp }
-        reWrap . BDFAnnotationRest annKey <$> rec bd
+        -- > bd' <- rec bd
-      BDFAnnotationKW annKey kw bd ->
+        -- not sure if the lineModeDecay is relevant any longer though..
-        reWrap . BDFAnnotationKW annKey kw <$> rec bd
+        reWrap . BDFFlushCommentsPrior loc <$> rec bd
-      BDFMoveToKWDP annKey kw b bd ->
+      BDFFlushCommentsPost loc bd ->
-        reWrap . BDFMoveToKWDP annKey kw b <$> rec bd
+        reWrap . BDFFlushCommentsPost loc <$> rec bd
       BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless.
       BDFLines (l : lr) -> do
         ind <- _acp_indent <$> mGet
@@ -456,21 +482,21 @@ getSpacing !bridoc = rec bridoc
           VerticalSpacingParNone -> mVs
           _ -> LineModeInvalid
       BDFForwardLineMode bd -> rec bd
-      BDFExternal _ _ _ txt -> return $ LineModeValid $ case Text.lines txt of
+      BDFExternal _ txt -> return $ LineModeValid $ case Text.lines txt of
         [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False
         _ -> VerticalSpacing 999 VerticalSpacingParNone False
       BDFPlain txt -> return $ LineModeValid $ case Text.lines txt of
         [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False
         _ -> VerticalSpacing 999 VerticalSpacingParNone False
-      BDFAnnotationPrior _annKey bd -> rec bd
+      BDFQueueComments _comms bd -> rec bd
-      BDFAnnotationKW _annKey _kw bd -> rec bd
+      BDFFlushCommentsPrior _loc bd -> rec bd
-      BDFAnnotationRest _annKey bd -> rec bd
+      BDFFlushCommentsPost _loc bd -> rec bd
-      BDFMoveToKWDP _annKey _kw _b bd -> rec bd
       BDFLines [] ->
         return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False
-      BDFLines ls@(_ : _) -> do
+      BDFLines (l1 : lR) -> do
-        lSps <- rec `mapM` ls
+        mVs <- rec l1
-        let (mVs : _) = lSps -- separated into let to avoid MonadFail
+        mVRs <- rec `mapM` lR
+        let lSps = mVs : mVRs
         return
           $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False
             | VerticalSpacing lsp _ _ <- mVs
@@ -751,7 +777,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
         mVs <- filterAndLimit <$> rec bd
         return $ filter ((== VerticalSpacingParNone) . _vs_paragraph) mVs
       BDFForwardLineMode bd -> rec bd
-      BDFExternal _ _ _ txt | [t] <- Text.lines txt ->
+      BDFExternal _ txt | [t] <- Text.lines txt ->
         return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False]
       BDFExternal{} -> return $ [] -- yes, we just assume that we cannot properly layout
                     -- this.
@@ -764,10 +790,9 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
               VerticalSpacing (Text.length t1) (VerticalSpacingParAlways 0) True
         | allowHangingQuasiQuotes
         ]
-      BDFAnnotationPrior _annKey bd -> rec bd
+      BDFQueueComments _comms bd -> rec bd
-      BDFAnnotationKW _annKey _kw bd -> rec bd
+      BDFFlushCommentsPrior _loc bd -> rec bd
-      BDFAnnotationRest _annKey bd -> rec bd
+      BDFFlushCommentsPost _loc bd -> rec bd
-      BDFMoveToKWDP _annKey _kw _b bd -> rec bd
       BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False]
       BDFLines ls@(_ : _) -> do
         -- we simply assume that lines is only used "properly", i.e. in

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

@@ -1,14 +1,12 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
-module Language.Haskell.Brittany.Internal.Transformations.Floating where
+module Language.Haskell.Brittany.Internal.Transformations.T2_Floating where
 
 import qualified Data.Generics.Uniplate.Direct as Uniplate
 import qualified GHC.OldList as List
 import Language.Haskell.Brittany.Internal.Prelude
-import Language.Haskell.Brittany.Internal.PreludeUtils
+import Language.Haskell.Brittany.Internal.Components.BriDoc
-import Language.Haskell.Brittany.Internal.Types
-import Language.Haskell.Brittany.Internal.Utils
 
 
 
@@ -29,68 +27,48 @@ transformSimplifyFloating = stepBO .> stepFull
   -- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence
   --         the push/pop cases would need to be copied over
  where
-  descendPrior = transformDownMay $ \case
+  descendCommsPrior = transformDownMay $ \case
     -- prior floating in
-    BDAnnotationPrior annKey1 (BDPar ind line indented) ->
+    BDFlushCommentsPrior loc1 (BDFlushCommentsPrior loc2 x) ->
-      Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented
+      Just $ BDFlushCommentsPrior (max loc1 loc2) x
-    BDAnnotationPrior annKey1 (BDSeq (l : lr)) ->
+    BDFlushCommentsPrior loc1 (BDPar ind line indented) ->
-      Just $ BDSeq (BDAnnotationPrior annKey1 l : lr)
+      Just $ BDPar ind (BDFlushCommentsPrior loc1 line) indented
-    BDAnnotationPrior annKey1 (BDLines (l : lr)) ->
+    BDFlushCommentsPrior loc1 (BDSeq (l : lr)) ->
-      Just $ BDLines (BDAnnotationPrior annKey1 l : lr)
+      Just $ BDSeq (BDFlushCommentsPrior loc1 l : lr)
-    BDAnnotationPrior annKey1 (BDCols sig (l : lr)) ->
+    BDFlushCommentsPrior loc1 (BDLines (l : lr)) ->
-      Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr)
+      Just $ BDLines (BDFlushCommentsPrior loc1 l : lr)
-    BDAnnotationPrior annKey1 (BDAddBaseY indent x) ->
+    BDFlushCommentsPrior loc1 (BDCols sig (l : lr)) ->
-      Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x
+      Just $ BDCols sig (BDFlushCommentsPrior loc1 l : lr)
-    BDAnnotationPrior annKey1 (BDDebug s x) ->
+    BDFlushCommentsPrior loc1 (BDAddBaseY indent x) ->
-      Just $ BDDebug s $ BDAnnotationPrior annKey1 x
+      Just $ BDAddBaseY indent $ BDFlushCommentsPrior loc1 x
+    BDFlushCommentsPrior loc1 (BDDebug s x) ->
+      Just $ BDDebug s $ BDFlushCommentsPrior loc1 x
     _ -> Nothing
-  descendRest = transformDownMay $ \case
+  descendCommsPost = transformDownMay $ \case
     -- post floating in
-    BDAnnotationRest annKey1 (BDPar ind line indented) ->
+    BDFlushCommentsPost loc1 (BDFlushCommentsPost loc2 x) ->
-      Just $ BDPar ind line $ BDAnnotationRest annKey1 indented
+      Just $ BDFlushCommentsPost (max loc1 loc2) x
-    BDAnnotationRest annKey1 (BDSeq list) ->
+    BDFlushCommentsPost loc1 (BDPar ind line indented) ->
+      Just $ BDPar ind line $ BDFlushCommentsPost loc1 indented
+    BDFlushCommentsPost loc1 (BDSeq list) ->
       Just
         $ BDSeq
         $ List.init list
-        ++ [BDAnnotationRest annKey1 $ List.last list]
+        ++ [BDFlushCommentsPost loc1 $ List.last list]
-    BDAnnotationRest annKey1 (BDLines list) ->
+    BDFlushCommentsPost loc1 (BDLines list) ->
       Just
         $ BDLines
         $ List.init list
-        ++ [BDAnnotationRest annKey1 $ List.last list]
+        ++ [BDFlushCommentsPost loc1 $ List.last list]
-    BDAnnotationRest annKey1 (BDCols sig cols) ->
+    BDFlushCommentsPost loc1 (BDCols sig cols) ->
       Just
         $ BDCols sig
         $ List.init cols
-        ++ [BDAnnotationRest annKey1 $ List.last cols]
+        ++ [BDFlushCommentsPost loc1 $ List.last cols]
-    BDAnnotationRest annKey1 (BDAddBaseY indent x) ->
+    BDFlushCommentsPost loc1 (BDAddBaseY indent x) ->
-      Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x
+      Just $ BDAddBaseY indent $ BDFlushCommentsPost loc1 x
-    BDAnnotationRest annKey1 (BDDebug s x) ->
+    BDFlushCommentsPost loc1 (BDDebug s x) ->
-      Just $ BDDebug s $ BDAnnotationRest annKey1 x
+      Just $ BDDebug s $ BDFlushCommentsPost loc1 x
-    _ -> Nothing
-  descendKW = transformDownMay $ \case
-    -- post floating in
-    BDAnnotationKW annKey1 kw (BDPar ind line indented) ->
-      Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented
-    BDAnnotationKW annKey1 kw (BDSeq list) ->
-      Just
-        $ BDSeq
-        $ List.init list
-        ++ [BDAnnotationKW annKey1 kw $ List.last list]
-    BDAnnotationKW annKey1 kw (BDLines list) ->
-      Just
-        $ BDLines
-        $ List.init list
-        ++ [BDAnnotationKW annKey1 kw $ List.last list]
-    BDAnnotationKW annKey1 kw (BDCols sig cols) ->
-      Just
-        $ BDCols sig
-        $ List.init cols
-        ++ [BDAnnotationKW annKey1 kw $ List.last cols]
-    BDAnnotationKW annKey1 kw (BDAddBaseY indent x) ->
-      Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x
-    BDAnnotationKW annKey1 kw (BDDebug s x) ->
-      Just $ BDDebug s $ BDAnnotationKW annKey1 kw x
     _ -> Nothing
   descendBYPush = transformDownMay $ \case
     BDBaseYPushCur (BDCols sig cols@(_ : _)) ->
@@ -124,12 +102,12 @@ transformSimplifyFloating = stepBO .> stepFull
     -- merge AddIndent and Par
     BDAddBaseY ind1 (BDPar ind2 line indented) ->
       Just $ BDPar (mergeIndents ind1 ind2) line indented
-    BDAddBaseY ind (BDAnnotationPrior annKey1 x) ->
+    BDAddBaseY ind (BDFlushCommentsPrior loc x) ->
-      Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x)
+      Just $ BDFlushCommentsPrior loc (BDAddBaseY ind x)
-    BDAddBaseY ind (BDAnnotationRest annKey1 x) ->
+    BDAddBaseY ind (BDFlushCommentsPost loc x) ->
-      Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x)
+      Just $ BDFlushCommentsPost loc (BDAddBaseY ind x)
-    BDAddBaseY ind (BDAnnotationKW annKey1 kw x) ->
+    BDAddBaseY ind (BDQueueComments comms x) ->
-      Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x)
+      Just $ BDQueueComments comms (BDAddBaseY ind x)
     BDAddBaseY ind (BDSeq list) ->
       Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]
     BDAddBaseY _ lit@BDLit{} -> Just $ lit
@@ -149,9 +127,9 @@ transformSimplifyFloating = stepBO .> stepFull
            transformUp f
    where
     f = \case
-      x@BDAnnotationPrior{} -> descendPrior x
+      BDSeq xs -> BDSeq (dropWhile (\case BDEmpty -> True; _ -> False) xs)
-      x@BDAnnotationKW{} -> descendKW x
+      x@BDFlushCommentsPrior{} -> descendCommsPrior x
-      x@BDAnnotationRest{} -> descendRest x
+      x@BDFlushCommentsPost{} -> descendCommsPost x
       x@BDAddBaseY{} -> descendAddB x
       x@BDBaseYPushCur{} -> descendBYPush x
       x@BDBaseYPop{} -> descendBYPop x
@@ -160,6 +138,10 @@ transformSimplifyFloating = stepBO .> stepFull
       x -> x
   stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $
              Uniplate.rewrite $ \case
+    BDSeq (BDEmpty : x) -> Just (BDSeq x)
+    -- TODO92 This could be rewritten, so that we re-use the
+    -- (BriDoc -> Maybe Bridoc) part of the descend* functions instead of
+    -- copying them here (incompletely).
     BDAddBaseY BrIndentNone x -> Just $ x
     -- AddIndent floats into Lines.
     BDAddBaseY indent (BDLines lines) ->
@@ -176,15 +158,6 @@ transformSimplifyFloating = stepBO .> stepFull
     BDAddBaseY ind (BDBaseYPushCur x) ->
       Just $ BDBaseYPushCur (BDAddBaseY ind x)
     BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x)
-    -- prior floating in
-    BDAnnotationPrior annKey1 (BDPar ind line indented) ->
-      Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented
-    BDAnnotationPrior annKey1 (BDSeq (l : lr)) ->
-      Just $ BDSeq ((BDAnnotationPrior annKey1 l) : lr)
-    BDAnnotationPrior annKey1 (BDLines (l : lr)) ->
-      Just $ BDLines ((BDAnnotationPrior annKey1 l) : lr)
-    BDAnnotationPrior annKey1 (BDCols sig (l : lr)) ->
-      Just $ BDCols sig ((BDAnnotationPrior annKey1 l) : lr)
     -- EnsureIndent float-in
     -- BDEnsureIndent indent (BDCols sig (col:colr)) ->
     --   Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr))
@@ -192,22 +165,23 @@ transformSimplifyFloating = stepBO .> stepFull
     -- unaffected.
     -- BDEnsureIndent indent (BDLines lines) ->
     --   Just $ BDLines $ BDEnsureIndent indent <$> lines
-    -- post floating in
+    -- flush-prior floating in
-    BDAnnotationRest annKey1 (BDPar ind line indented) ->
+    BDFlushCommentsPrior loc (BDPar ind line indented) ->
-      Just $ BDPar ind line $ BDAnnotationRest annKey1 indented
+      Just $ BDPar ind (BDFlushCommentsPrior loc line) indented
-    BDAnnotationRest annKey1 (BDSeq list) ->
+    BDFlushCommentsPrior loc (BDSeq (l : lr)) ->
-      Just
+      Just $ BDSeq (BDFlushCommentsPrior loc l : lr)
-        $ BDSeq
+    BDFlushCommentsPrior loc (BDLines (l : lr)) ->
-        $ List.init list
+      Just $ BDLines (BDFlushCommentsPrior loc l : lr)
-        ++ [BDAnnotationRest annKey1 $ List.last list]
+    BDFlushCommentsPrior loc (BDCols sig (l : lr)) ->
-    BDAnnotationRest annKey1 (BDLines list) ->
+      Just $ BDCols sig (BDFlushCommentsPrior loc l : lr)
-      Just
+    -- flush-post floating in
-        $ BDLines
+    BDFlushCommentsPost comms1 (BDPar ind line indented) ->
-        $ List.init list
+      Just $ BDPar ind line $ BDFlushCommentsPost comms1 indented
-        ++ [BDAnnotationRest annKey1 $ List.last list]
+    BDFlushCommentsPost loc (BDSeq list) ->
-    BDAnnotationRest annKey1 (BDCols sig cols) ->
+      Just $ BDSeq $ List.init list ++ [BDFlushCommentsPost loc $ List.last list]
-      Just
+    BDFlushCommentsPost loc (BDLines list) -> Just
-        $ BDCols sig
+      $ BDLines $ List.init list ++ [BDFlushCommentsPost loc $ List.last list]
-        $ List.init cols
+    BDFlushCommentsPost loc (BDCols sig list) -> Just
-        ++ [BDAnnotationRest annKey1 $ List.last cols]
+      $ BDCols sig $ List.init list ++ [BDFlushCommentsPost loc $ List.last list]
+
     _ -> Nothing

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

@@ -1,11 +1,10 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
-module Language.Haskell.Brittany.Internal.Transformations.Par where
+module Language.Haskell.Brittany.Internal.Transformations.T3_Par where
 
 import Language.Haskell.Brittany.Internal.Prelude
-import Language.Haskell.Brittany.Internal.Types
+import Language.Haskell.Brittany.Internal.Components.BriDoc
-import Language.Haskell.Brittany.Internal.Utils
 
 
 
@@ -16,7 +15,12 @@ transformSimplifyPar = transformUp $ \case
   --   Just $ BDLines [line, indented]
   -- BDPar ind1 (BDPar ind2 line p1) p2 | ind1==ind2 ->
   --   Just $ BDPar ind1 line (BDLines [p1, p2])
+
+  -- TODO92 is this still necessary? No tests fail, but maybe
+  --        performance gets worse.
   x@(BDPar _ (BDPar _ BDPar{} _) _) -> x
+  -- this is a combination of other transformations below, the
+  -- important one is the next one.
   BDPar ind1 (BDPar ind2 line p1) (BDLines indenteds) ->
     BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds))
   BDPar ind1 (BDPar ind2 line p1) p2 ->
@@ -29,13 +33,16 @@ transformSimplifyPar = transformUp $ \case
         _ -> False
       )
       lines
-    -> case go lines of
+    -> case lines >>= flattenToDocList of
       [] -> BDEmpty
       [x] -> x
       xs -> BDLines xs
    where
-    go = (=<<) $ \case
+    flattenToDocList = \case
-      BDLines l -> go l
+      -- note that this is a transformUp, so we create the invariant that
+      -- BDLines does not contain BDEmpty or BDLines, but we may assume the
+      -- BDLines below are already flattened.
+      BDLines xs -> xs
       BDEmpty -> []
       x -> [x]
   BDLines [] -> BDEmpty

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

@@ -1,12 +1,12 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
-module Language.Haskell.Brittany.Internal.Transformations.Columns where
+module Language.Haskell.Brittany.Internal.Transformations.T4_Columns where
 
 import qualified Data.Generics.Uniplate.Direct as Uniplate
 import qualified GHC.OldList as List
 import Language.Haskell.Brittany.Internal.Prelude
-import Language.Haskell.Brittany.Internal.Types
+import Language.Haskell.Brittany.Internal.Components.BriDoc
 
 
 
@@ -32,6 +32,8 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
     | all
       (\case
         BDSeparator -> True
+        BDFlushCommentsPrior _ BDSeparator -> True
+        BDFlushCommentsPost _ BDSeparator -> True
         _ -> False
       )
       rest
@@ -47,41 +49,20 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
     -> Just $ BDLines $ filter isNotEmpty $ lines >>= \case
       BDLines l -> l
       x -> [x]
-  -- prior floating in
+  -- flush-prior floating in
-  BDAnnotationPrior annKey1 (BDSeq (l : lr)) ->
+  BDFlushCommentsPrior loc (BDSeq (l : lr)) ->
-    Just $ BDSeq (BDAnnotationPrior annKey1 l : lr)
+    Just $ BDSeq (BDFlushCommentsPrior loc l : lr)
-  BDAnnotationPrior annKey1 (BDLines (l : lr)) ->
+  BDFlushCommentsPrior loc (BDLines (l : lr)) ->
-    Just $ BDLines (BDAnnotationPrior annKey1 l : lr)
+    Just $ BDLines (BDFlushCommentsPrior loc l : lr)
-  BDAnnotationPrior annKey1 (BDCols sig (l : lr)) ->
+  BDFlushCommentsPrior loc (BDCols sig (l : lr)) ->
-    Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr)
+    Just $ BDCols sig (BDFlushCommentsPrior loc l : lr)
-  -- post floating in
+  -- flush-post floating in
-  BDAnnotationRest annKey1 (BDSeq list) ->
+  BDFlushCommentsPost loc (BDSeq list) ->
-    Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
+    Just $ BDSeq $ List.init list ++ [BDFlushCommentsPost loc $ List.last list]
-  BDAnnotationRest annKey1 (BDLines list) ->
+  BDFlushCommentsPost loc (BDLines list) -> Just
-    Just
+    $ BDLines $ List.init list ++ [BDFlushCommentsPost loc $ List.last list]
-      $ BDLines
+  BDFlushCommentsPost loc (BDCols sig list) -> Just
-      $ List.init list
+    $ BDCols sig $ List.init list ++ [BDFlushCommentsPost loc $ List.last list]
-      ++ [BDAnnotationRest annKey1 $ List.last list]
-  BDAnnotationRest annKey1 (BDCols sig cols) ->
-    Just
-      $ BDCols sig
-      $ List.init cols
-      ++ [BDAnnotationRest annKey1 $ List.last cols]
-  BDAnnotationKW annKey1 kw (BDSeq list) ->
-    Just
-      $ BDSeq
-      $ List.init list
-      ++ [BDAnnotationKW annKey1 kw $ List.last list]
-  BDAnnotationKW annKey1 kw (BDLines list) ->
-    Just
-      $ BDLines
-      $ List.init list
-      ++ [BDAnnotationKW annKey1 kw $ List.last list]
-  BDAnnotationKW annKey1 kw (BDCols sig cols) ->
-    Just
-      $ BDCols sig
-      $ List.init cols
-      ++ [BDAnnotationKW annKey1 kw $ List.last cols]
   -- ensureIndent float-in
   -- not sure if the following rule is necessary; tests currently are
   -- unaffected.
@@ -151,10 +132,9 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
   BDExternal{} -> Nothing
   BDPlain{} -> Nothing
   BDLines{} -> Nothing
-  BDAnnotationPrior{} -> Nothing
+  BDQueueComments{} -> Nothing
-  BDAnnotationKW{} -> Nothing
+  BDFlushCommentsPrior{} -> Nothing
-  BDAnnotationRest{} -> Nothing
+  BDFlushCommentsPost{} -> Nothing
-  BDMoveToKWDP{} -> Nothing
   BDEnsureIndent{} -> Nothing
   BDSetParSpacing{} -> Nothing
   BDForceParSpacing{} -> Nothing

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

@@ -1,12 +1,12 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
-module Language.Haskell.Brittany.Internal.Transformations.Indent where
+module Language.Haskell.Brittany.Internal.Transformations.T5_Indent where
 
 import qualified Data.Generics.Uniplate.Direct as Uniplate
 import qualified GHC.OldList as List
 import Language.Haskell.Brittany.Internal.Prelude
-import Language.Haskell.Brittany.Internal.Types
+import Language.Haskell.Brittany.Internal.Components.BriDoc
 
 
 
@@ -16,6 +16,7 @@ import Language.Haskell.Brittany.Internal.Types
 transformSimplifyIndent :: BriDoc -> BriDoc
 transformSimplifyIndent = Uniplate.rewrite $ \case
   BDPar ind (BDLines lines) indented ->
+    -- error "foo"
     Just $ BDEnsureIndent ind $ BDLines $ lines ++ [indented]
   BDPar ind (BDCols sig cols) indented ->
     Just $ BDCols sig (List.init cols ++ [BDPar ind (List.last cols) indented])
@@ -39,12 +40,10 @@ transformSimplifyIndent = Uniplate.rewrite $ \case
       BDLines l -> l
       x -> [x]
   BDLines [l] -> Just l
-  BDAddBaseY i (BDAnnotationPrior k x) ->
+  BDAddBaseY i (BDFlushCommentsPrior c x) ->
-    Just $ BDAnnotationPrior k (BDAddBaseY i x)
+    Just $ BDFlushCommentsPrior c (BDAddBaseY i x)
-  BDAddBaseY i (BDAnnotationKW k kw x) ->
+  BDAddBaseY i (BDFlushCommentsPost c x) ->
-    Just $ BDAnnotationKW k kw (BDAddBaseY i x)
+    Just $ BDFlushCommentsPost c (BDAddBaseY i x)
-  BDAddBaseY i (BDAnnotationRest k x) ->
-    Just $ BDAnnotationRest k (BDAddBaseY i x)
   BDAddBaseY i (BDSeq l) ->
     Just $ BDSeq $ List.init l ++ [BDAddBaseY i $ List.last l]
   BDAddBaseY i (BDCols sig l) ->

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

@@ -1,118 +1,197 @@
+{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DerivingStrategies #-}
 
 module Language.Haskell.Brittany.Internal.Types where
 
 import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
 import qualified Data.Data
-import Data.Generics.Uniplate.Direct as Uniplate
 import qualified Data.Kind as Kind
-import qualified Data.Strict.Maybe as Strict
+import qualified GHC.OldList as List
 import qualified Data.Text.Lazy.Builder as Text.Builder
-import GHC (AnnKeywordId, GenLocated, Located, SrcSpan)
+import           GHC                            ( Anno
+                                                , DeltaPos
+                                                  ( DifferentLine
+                                                  , SameLine
+                                                  )
+                                                , EpaCommentTok
+                                                , LHsDecl
+                                                , ParsedSource
+                                                , XRec
+                                                , LImportDecl
+                                                )
+import GHC.Utils.Outputable(Outputable)
 import Language.Haskell.Brittany.Internal.Config.Types
 import Language.Haskell.Brittany.Internal.Prelude
-import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
+import Language.Haskell.Brittany.Internal.Components.BriDoc
-import Language.Haskell.GHC.ExactPrint (AnnKey)
-import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
-import Language.Haskell.GHC.ExactPrint.Types (Anns)
-import qualified Safe
 
 
-data PerItemConfig = PerItemConfig
-  { _icd_perBinding :: Map String (CConfig Maybe)
-  , _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Maybe)
-  }
-  deriving Data.Data.Data
 
-type PPM = MultiRWSS.MultiRWS
+-- brittany-internal error type, part of the brittany library public interface.
-  '[Map ExactPrint.AnnKey ExactPrint.Anns, PerItemConfig, Config, ExactPrint.Anns]
+data BrittanyError
-  '[Text.Builder.Builder, [BrittanyError], Seq String]
+  = ErrorInput String
-  '[]
+    -- ^ parsing failed
+  | ErrorUnusedComment String
+    -- ^ internal error: some comment went missing. Since ghc-9.2 the one below
+    --   is used for missing comments while layouting top-level decls.
+    --   You might still get thse for import/export statement comments (right?)
+    --   (TODO this needs updating once the ghc-9.2 implementation is complete)
+  | ErrorUnusedComments (LHsDecl GhcPs) Int Int
+    -- ^ internal error: some comments went missing while layouting the
+    --   specified top-level declaration (module child).
+  | ErrorMacroConfig String String
+    -- ^ in-source config string parsing error; first argument is the parser
+    --   output and second the corresponding, ill-formed input.
+  | LayoutWarning String
+    -- ^ some warning
+  | 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
+    -- ^ checking the output for syntactic validity failed
+
+
+-- General-purpose structure. Church-encoded version of a list that has a
+-- parameterized final value.
+-- That is:
+-- 1) Start with a dumb old `List a = Cons a (List a) | Empty`
+-- 2) Parameterize the empty `ListEnd a b = Cons a (List a b) | Final b`
+-- 3) Church-encode the result for good measure (and better perf?)
+--
+-- This is similar to a Writer Monad, and maybe it already exists somewhere,
+-- but it feels like a) This abstraction doesn't leak by itself b) you can
+-- trivially turn it into something that streams into some "consuming" monadic
+-- action c) it is _simple_, doesn't require a monoid or anything without
+-- losing anything.
+data FinalList a b = FinalList (forall r . (a -> r -> r) -> (b -> r) -> r)
+
+finalPure :: b -> FinalList a b
+finalPure b = FinalList $ \_ f -> f b
+finalCons :: a -> FinalList a b -> FinalList a b
+finalCons a (FinalList l) = FinalList (\f1 f2 -> f1 a $ l f1 f2)
+finalBind :: FinalList a b -> (b -> FinalList a b) -> FinalList a b
+finalBind (FinalList l) f =
+  FinalList (\f1 f2 -> l f1 (\b -> let FinalList c = (f b) in c f1 f2))
+_finalSingleton :: a -> b -> FinalList a b
+_finalSingleton a b = FinalList (\f1 f2 -> f1 a (f2 b))
+_finalLMap :: (a -> a') -> FinalList a b -> FinalList a' b
+_finalLMap f (FinalList l) = FinalList (\f1 f2 -> l (f1 . f) f2)
+_finalRMap :: (b -> b') -> FinalList a b -> FinalList a b'
+_finalRMap f (FinalList l) = FinalList (\f1 f2 -> l f1 (f2 . f))
+finalYield :: a -> FinalList a ()
+finalYield x = FinalList $ \f1 f2 -> f1 x (f2 ())
+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))
+
+instance Functor (FinalList a) where
+  fmap = _finalRMap
+
+instance Applicative (FinalList a) where
+  pure = finalPure
+  FinalList ff <*> FinalList fx =
+    FinalList $ \f1 f2 -> ff f1 (\g -> fx f1 (f2 . g))
+
+instance Monad (FinalList a) where
+  FinalList fx >>= f =
+    FinalList $ \f1 f2 -> fx f1 (\x -> let FinalList c = f x in c f1 f2)
+
+-- After parsing, we split a module into a series of these so that
+-- we can process them independently.
+data ModuleElement
+  = MEExactModuleHead ParsedSource
+    -- ^ When not pretty-printing the module head:
+    --   module name, imports, exports, but without decls.
+    --   Could split out the relevant fields, but we need the full (with decls
+    --   set to []) for exactprinting anyway.
+  | MEPrettyModuleHead ParsedSource
+    -- ^ Similar, but when pretty-printing the head:
+    --   This encompasses just the module name, the exports and
+    --   the where keyword. Everything else (including comments in
+    --   various places) get 
+  | MEImportDecl (LImportDecl GhcPs) [(Int, EpaCommentTok)]
+    -- ^ an import decl, only occurs if pretty-printing the module head.
+  | MEDecl (LHsDecl GhcPs) [(Int, EpaCommentTok)]
+    -- ^ a top-level declaration
+  | 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.
+  | MEWhitespace DeltaPos
+  -- ^ Empty lines around decls.
+
+
+newtype TraceFunc = TraceFunc { useTraceFunc :: String -> IO () }
 
 type PPMLocal = MultiRWSS.MultiRWS
-  '[Config, ExactPrint.Anns]
+  '[Config, TraceFunc]
   '[Text.Builder.Builder, [BrittanyError], Seq String]
-  '[]
+  '[CommentCounter]
 
-newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map ExactPrint.AnnKey String)
+-- type LayoutConstraints m
+--   = ( MonadMultiReader Config m
+--     , MonadMultiWriter TextL.Builder.Builder m
+--     , MonadMultiWriter (Seq String) m
+--     , MonadMultiState LayoutState m
+--     , MonadMultiState CommentCounter m
+--     , MonadMultiState [GHC.LEpaComment] m
+--     )
 
-data LayoutState = LayoutState
+ppmMoveToExactLoc
-  { _lstate_baseYs         :: [Int]
+  :: MonadMultiWriter Text.Builder.Builder m => GHC.DeltaPos -> m ()
-     -- ^ stack of number of current indentation columns
+ppmMoveToExactLoc = \case
-     -- (not number of indentations).
+  SameLine c ->
-  , _lstate_curYOrAddNewline :: Either Int Int
+    mTell $ Text.Builder.fromString (List.replicate c ' ')
-             -- ^ Either:
+  DifferentLine l c -> mTell $ Text.Builder.fromString
-             -- 1) number of chars in the current line.
+    (List.replicate l '\n' ++ List.replicate (c - 1) ' ')
-             -- 2) number of newlines to be inserted before inserting any
-             --    non-space elements.
-  , _lstate_indLevels      :: [Int]
-    -- ^ stack of current indentation levels. set for
-    -- any layout-affected elements such as
-    -- let/do/case/where elements.
-    -- The main purpose of this member is to
-    -- properly align comments, as their
-    -- annotation positions are relative to the
-    -- current layout indentation level.
-  , _lstate_indLevelLinger :: Int -- like a "last" of indLevel. Used for
-                                  -- properly treating cases where comments
-                                  -- on the first indented element have an
-                                  -- annotation offset relative to the last
-                                  -- non-indented element, which is confusing.
-  , _lstate_comments      :: Anns
-  , _lstate_commentCol    :: Maybe Int -- this communicates two things:
-                                       -- firstly, that cursor is currently
-                                       -- at the end of a comment (so needs
-                                       -- newline before any actual content).
-                                       -- secondly, the column at which
-                                       -- insertion of comments started.
-  , _lstate_addSepSpace   :: Maybe Int -- number of spaces to insert if anyone
-                                       -- writes (any non-spaces) in the
-                                       -- current line.
-  -- , _lstate_isNewline     :: NewLineState
-  --     -- captures if the layouter currently is in a new line, i.e. if the
-  --     -- current line only contains (indentation) spaces.
-  -- this is mostly superseeded by curYOrAddNewline, iirc.
-  , _lstate_commentNewlines :: Int -- number of newlines inserted due to
-                                   -- move-to-DP at a start of a comment.
-                                   -- Necessary because some keyword DPs
-                                   -- are relative to the last non-comment
-                                   -- entity (for some reason).
-                                   -- This is not very strictly reset to 0,
-                                   -- so we might in some cases get "artifacts"
-                                   -- from previous document elements.
-                                   -- But the worst effect at the moment would
-                                   -- be that we introduce less newlines on
-                                   -- moveToKWDP, which seems harmless enough.
-  }
 
-lstate_baseY :: LayoutState -> Int
-lstate_baseY = Safe.headNote "lstate_baseY" . _lstate_baseYs
 
-lstate_indLevel :: LayoutState -> Int
+type ToBriDocM = MultiRWSS.MultiRWS
-lstate_indLevel = Safe.headNote "lstate_baseY" . _lstate_indLevels
+  '[Config, TraceFunc] -- reader
+  '[[BrittanyError], Seq String] -- writer
+  '[NodeAllocIndex, CommentCounter] -- state
+
+type ToBriDoc (sym :: Kind.Type -> Kind.Type) = XRec GhcPs (sym GhcPs) -> ToBriDocM BriDocNumbered
+type ToBriDoc' sym            = XRec GhcPs (sym GhcPs)                 -> ToBriDocM BriDocNumbered
+type ToBriDocC sym c          = XRec GhcPs (sym GhcPs)                 -> ToBriDocM c
+type ToBriDocP sym            = sym GhcPs                              -> ToBriDocM BriDocNumbered
+
+
+newtype CommentCounter = CommentCounter { unCommentCounter :: Int }
+  deriving (Eq, Ord, Num, Data.Data.Data)
+  deriving newtype (Show)
+
+-- Why does this live in types? As long as it does, you _have_
+-- to remember to call `docFlushRemaining` in combination with this!
+briDocMToPPM :: ToBriDocM a -> PPMLocal (a, Int)
+briDocMToPPM m = do
+  readers <- MultiRWSS.mGetRawR
+  initCount <- MultiRWSS.mGet @CommentCounter
+  let
+    (((x, errs), debugs), commentCount) =
+      runIdentity
+        $ MultiRWSS.runMultiRWSTNil
+        $ MultiRWSS.withMultiStateAS initCount
+        $ MultiRWSS.withMultiStateA (NodeAllocIndex 1)
+        $ MultiRWSS.withMultiReaders readers
+        $ MultiRWSS.withMultiWriterAW
+        $ MultiRWSS.withMultiWriterAW
+        $ m
+  mTell debugs
+  mTell errs
+  mSet commentCount
+  pure (x, length errs)
+
+
+
+newtype NodeAllocIndex = NodeAllocIndex Int
+
 
--- evil, incomplete Show instance; only for debugging.
-instance Show LayoutState where
-  show state =
-    "LayoutState"
-    ++ "{baseYs=" ++ show (_lstate_baseYs state)
-    ++ ",curYOrAddNewline=" ++ show (_lstate_curYOrAddNewline state)
-    ++ ",indLevels=" ++ show (_lstate_indLevels state)
-    ++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state)
-    ++ ",commentCol=" ++ show (_lstate_commentCol state)
-    ++ ",addSepSpace=" ++ show (_lstate_addSepSpace state)
-    ++ ",commentNewlines=" ++ show (_lstate_commentNewlines state)
-    ++ "}"
 
 -- data NewLineState = NewLineStateInit -- initial state. we do not know if in a
 --                                      -- newline, really. by special-casing
@@ -134,330 +213,13 @@ instance Show LayoutState where
 --   , _lsettings_initialAnns :: ExactPrint.Anns
 --   }
 
-data BrittanyError
-  = ErrorInput String
-    -- ^ parsing failed
-  | ErrorUnusedComment String
-    -- ^ internal error: some comment went missing
-  | ErrorMacroConfig String String
-    -- ^ in-source config string parsing error; first argument is the parser
-    --   output and second the corresponding, ill-formed input.
-  | LayoutWarning String
-    -- ^ some warning
-  | forall ast . Data.Data.Data ast => ErrorUnknownNode String (GenLocated SrcSpan ast)
-    -- ^ internal error: pretty-printing is not implemented for type of node
-    --   in the syntax-tree
-  | ErrorOutputCheck
-    -- ^ checking the output for syntactic validity failed
 
-data BriSpacing = BriSpacing
+-- TODO92 is this old leftover, or useful future idea?
-  { _bs_spacePastLineIndent :: Int -- space in the current,
+-- data BriSpacing = BriSpacing
-                                   -- potentially somewhat filled
+--   { _bs_spacePastLineIndent :: Int -- space in the current,
-                                   -- line.
+--                                    -- potentially somewhat filled
-  , _bs_spacePastIndent :: Int     -- space required in properly
+--                                    -- line.
-                                   -- indented blocks below the
+--   , _bs_spacePastIndent :: Int     -- space required in properly
-                                   -- current line.
+--                                    -- indented blocks below the
-  }
+--                                    -- current line.
-
+--   }
-data ColSig
-  = ColTyOpPrefix
-    -- any prefixed operator/paren/"::"/..
-    -- expected to have exactly two colums.
-    -- e.g. ":: foo"
-    --       111222
-    --      "-> bar asd asd"
-    --       11122222222222
-  | ColPatternsFuncPrefix
-    -- pattern-part of the lhs, e.g. "func (foo a b) c _".
-    -- Has variable number of columns depending on the number of patterns.
-  | ColPatternsFuncInfix
-    -- pattern-part of the lhs, e.g. "Foo a <> Foo b".
-    -- Has variable number of columns depending on the number of patterns.
-  | ColPatterns
-  | ColCasePattern
-  | ColBindingLine (Maybe Text)
-    -- e.g. "func pat pat = expr"
-    --       1111111111111222222
-    -- or   "pat | stmt -> expr"
-    --       111111111112222222
-    -- expected to have exactly two columns.
-  | ColGuard
-    -- e.g. "func pat pat | cond = ..."
-    --       11111111111112222222
-    -- or   "pat | cond1, cond2 -> ..."
-    --       1111222222222222222
-    -- expected to have exactly two columns
-  | ColGuardedBody
-    -- e.g. | foofoo = 1
-    --      | bar    = 2
-    --      111111111222
-    -- expected to have exactly two columns
-  | ColBindStmt
-  | ColDoLet -- the non-indented variant
-  | ColRec
-  | ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect?
-  | ColRecDecl
-  | ColListComp
-  | ColList
-  | ColApp Text
-  | ColTuple
-  | ColTuples
-  | ColOpPrefix -- merge with ColList ? other stuff?
-  | ColImport
-
-  -- TODO
-  deriving (Eq, Ord, Data.Data.Data, Show)
-
-data BrIndent = BrIndentNone
-              | BrIndentRegular
-              | BrIndentSpecial Int
-  deriving (Eq, Ord, Data.Data.Data, Show)
-
-type ToBriDocM = MultiRWSS.MultiRWS
-                   '[Config, Anns] -- reader
-                   '[[BrittanyError], Seq String] -- writer
-                   '[NodeAllocIndex] -- state
-
-type ToBriDoc (sym :: Kind.Type -> Kind.Type) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered
-type ToBriDoc' sym            = Located sym         -> ToBriDocM BriDocNumbered
-type ToBriDocC sym c          = Located sym         -> ToBriDocM c
-
-data DocMultiLine
-  = MultiLineNo
-  | MultiLinePossible
-  deriving (Eq)
-
--- isomorphic to BriDocF Identity. Provided for ease of use, as we do a lot
--- of transformations on `BriDocF Identity`s and it is really annoying to
--- `Identity`/`runIdentity` everywhere.
-data BriDoc
-  = -- BDWrapAnnKey AnnKey BriDoc
-    BDEmpty
-  | BDLit !Text
-  | BDSeq [BriDoc] -- elements other than the last should
-                   -- not contains BDPars.
-  | BDCols ColSig [BriDoc] -- elements other than the last
-                         -- should not contains BDPars
-  | BDSeparator -- semantically, space-unless-at-end-of-line.
-  | BDAddBaseY BrIndent BriDoc
-  | BDBaseYPushCur BriDoc
-  | BDBaseYPop BriDoc
-  | BDIndentLevelPushCur BriDoc
-  | BDIndentLevelPop BriDoc
-  | BDPar
-    { _bdpar_indent :: BrIndent
-    , _bdpar_restOfLine :: BriDoc -- should not contain other BDPars
-    , _bdpar_indented :: BriDoc
-    }
-  -- | BDAddIndent BrIndent (BriDocF f)
-  -- | BDNewline
-  | BDAlt [BriDoc]
-  | BDForwardLineMode BriDoc
-  | BDExternal AnnKey
-               (Set AnnKey) -- set of annkeys contained within the node
-                            -- to be printed via exactprint
-               Bool -- should print extra comment ?
-               Text
-  | BDPlain !Text -- used for QuasiQuotes, content can be multi-line
-                  -- (contrast to BDLit)
-  | BDAnnotationPrior AnnKey BriDoc
-  | BDAnnotationKW AnnKey (Maybe AnnKeywordId) BriDoc
-  | BDAnnotationRest  AnnKey BriDoc
-  | BDMoveToKWDP AnnKey AnnKeywordId Bool BriDoc -- True if should respect x offset
-  | BDLines [BriDoc]
-  | BDEnsureIndent BrIndent BriDoc
-  -- the following constructors are only relevant for the alt transformation
-  -- and are removed afterwards. They should never occur in any BriDoc
-  -- after the alt transformation.
-  | BDForceMultiline BriDoc
-  | BDForceSingleline BriDoc
-  | BDNonBottomSpacing Bool BriDoc
-  | BDSetParSpacing BriDoc
-  | BDForceParSpacing BriDoc
-  -- pseudo-deprecated
-  | BDDebug String BriDoc
-  deriving (Data.Data.Data, Eq, Ord)
-
-data BriDocF f
-  = -- BDWrapAnnKey AnnKey BriDoc
-    BDFEmpty
-  | BDFLit !Text
-  | BDFSeq [f (BriDocF f)] -- elements other than the last should
-                   -- not contains BDPars.
-  | BDFCols ColSig [f (BriDocF f)] -- elements other than the last
-                         -- should not contains BDPars
-  | BDFSeparator -- semantically, space-unless-at-end-of-line.
-  | BDFAddBaseY BrIndent (f (BriDocF f))
-  | BDFBaseYPushCur (f (BriDocF f))
-  | BDFBaseYPop (f (BriDocF f))
-  | BDFIndentLevelPushCur (f (BriDocF f))
-  | BDFIndentLevelPop (f (BriDocF f))
-  | BDFPar
-    { _bdfpar_indent :: BrIndent
-    , _bdfpar_restOfLine :: f (BriDocF f) -- should not contain other BDPars
-    , _bdfpar_indented :: f (BriDocF f)
-    }
-  -- | BDAddIndent BrIndent (BriDocF f)
-  -- | BDNewline
-  | BDFAlt [f (BriDocF f)]
-  | BDFForwardLineMode (f (BriDocF f))
-  | BDFExternal AnnKey
-               (Set AnnKey) -- set of annkeys contained within the node
-                            -- to be printed via exactprint
-               Bool -- should print extra comment ?
-               Text
-  | BDFPlain !Text -- used for QuasiQuotes, content can be multi-line
-                   -- (contrast to BDLit)
-  | BDFAnnotationPrior AnnKey (f (BriDocF f))
-  | BDFAnnotationKW AnnKey (Maybe AnnKeywordId) (f (BriDocF f))
-  | BDFAnnotationRest  AnnKey (f (BriDocF f))
-  | BDFMoveToKWDP AnnKey AnnKeywordId Bool (f (BriDocF f)) -- True if should respect x offset
-  | BDFLines [(f (BriDocF f))]
-  | BDFEnsureIndent BrIndent (f (BriDocF f))
-  | BDFForceMultiline (f (BriDocF f))
-  | BDFForceSingleline (f (BriDocF f))
-  | BDFNonBottomSpacing Bool (f (BriDocF f))
-  | BDFSetParSpacing (f (BriDocF f))
-  | BDFForceParSpacing (f (BriDocF f))
-  | BDFDebug String (f (BriDocF f))
-
--- deriving instance Data.Data.Data (BriDocF Identity)
-deriving instance Data.Data.Data (BriDocF ((,) Int))
-
-type BriDocFInt = BriDocF ((,) Int)
-type BriDocNumbered = (Int, BriDocFInt)
-
-instance Uniplate.Uniplate BriDoc where
-  uniplate x@BDEmpty{}               = plate x
-  uniplate x@BDLit{}                 = plate x
-  uniplate (BDSeq list     )         = plate BDSeq ||* list
-  uniplate (BDCols sig list)         = plate BDCols |- sig ||* list
-  uniplate x@BDSeparator             = plate x
-  uniplate (BDAddBaseY ind bd      ) = plate BDAddBaseY |- ind |* bd
-  uniplate (BDBaseYPushCur       bd) = plate BDBaseYPushCur |* bd
-  uniplate (BDBaseYPop           bd) = plate BDBaseYPop |* bd
-  uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd
-  uniplate (BDIndentLevelPop     bd) = plate BDIndentLevelPop |* bd
-  uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented
-  uniplate (BDAlt             alts ) = plate BDAlt ||* alts
-  uniplate (BDForwardLineMode bd   ) = plate BDForwardLineMode |* bd
-  uniplate x@BDExternal{}            = plate x
-  uniplate x@BDPlain{}               = plate x
-  uniplate (BDAnnotationPrior annKey bd) =
-    plate BDAnnotationPrior |- annKey |* bd
-  uniplate (BDAnnotationKW annKey kw bd) =
-    plate BDAnnotationKW |- annKey |- kw |* bd
-  uniplate (BDAnnotationRest annKey bd) =
-    plate BDAnnotationRest |- annKey |* bd
-  uniplate (BDMoveToKWDP annKey kw b bd) =
-    plate BDMoveToKWDP |- annKey |- kw |- b |* bd
-  uniplate (BDLines lines          ) = plate BDLines ||* lines
-  uniplate (BDEnsureIndent ind bd  ) = plate BDEnsureIndent |- ind |* bd
-  uniplate (BDForceMultiline  bd   ) = plate BDForceMultiline |* bd
-  uniplate (BDForceSingleline bd   ) = plate BDForceSingleline |* bd
-  uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd
-  uniplate (BDSetParSpacing   bd   ) = plate BDSetParSpacing |* bd
-  uniplate (BDForceParSpacing bd   ) = plate BDForceParSpacing |* bd
-  uniplate (BDDebug s bd           ) = plate BDDebug |- s |* bd
-
-newtype NodeAllocIndex = NodeAllocIndex Int
-
--- TODO: rename to "dropLabels" ?
-unwrapBriDocNumbered :: BriDocNumbered -> BriDoc
-unwrapBriDocNumbered tpl = case snd tpl of
-  BDFEmpty                     -> BDEmpty
-  BDFLit t                     -> BDLit t
-  BDFSeq list                  -> BDSeq $ rec <$> list
-  BDFCols sig list             -> BDCols sig $ rec <$> list
-  BDFSeparator                 -> BDSeparator
-  BDFAddBaseY ind bd           -> BDAddBaseY ind $ rec bd
-  BDFBaseYPushCur       bd     -> BDBaseYPushCur $ rec bd
-  BDFBaseYPop           bd     -> BDBaseYPop $ rec bd
-  BDFIndentLevelPushCur bd     -> BDIndentLevelPushCur $ rec bd
-  BDFIndentLevelPop     bd     -> BDIndentLevelPop $ rec bd
-  BDFPar ind line indented     -> BDPar ind (rec line) (rec indented)
-  BDFAlt             alts      -> BDAlt $ rec <$> alts -- not that this will happen
-  BDFForwardLineMode bd        -> BDForwardLineMode $ rec bd
-  BDFExternal k ks c t         -> BDExternal k ks c t
-  BDFPlain t                   -> BDPlain t
-  BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd
-  BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd
-  BDFAnnotationRest annKey bd  -> BDAnnotationRest annKey $ rec bd
-  BDFMoveToKWDP annKey kw b bd -> BDMoveToKWDP annKey kw b $ rec bd
-  BDFLines lines               -> BDLines $ rec <$> lines
-  BDFEnsureIndent ind bd       -> BDEnsureIndent ind $ rec bd
-  BDFForceMultiline  bd        -> BDForceMultiline $ rec bd
-  BDFForceSingleline bd        -> BDForceSingleline $ rec bd
-  BDFNonBottomSpacing b bd     -> BDNonBottomSpacing b $ rec bd
-  BDFSetParSpacing   bd        -> BDSetParSpacing $ rec bd
-  BDFForceParSpacing bd        -> BDForceParSpacing $ rec bd
-  BDFDebug s bd                -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd
-  where rec = unwrapBriDocNumbered
-
-isNotEmpty :: BriDoc -> Bool
-isNotEmpty BDEmpty = False
-isNotEmpty _       = True
-
--- this might not work. is not used anywhere either.
-briDocSeqSpine :: BriDoc -> ()
-briDocSeqSpine = \case
-  BDEmpty                        -> ()
-  BDLit _t                       -> ()
-  BDSeq list                     -> foldl' ((briDocSeqSpine .) . seq) () list
-  BDCols _sig list               -> foldl' ((briDocSeqSpine .) . seq) () list
-  BDSeparator                    -> ()
-  BDAddBaseY _ind bd             -> briDocSeqSpine bd
-  BDBaseYPushCur       bd        -> briDocSeqSpine bd
-  BDBaseYPop           bd        -> briDocSeqSpine bd
-  BDIndentLevelPushCur bd        -> briDocSeqSpine bd
-  BDIndentLevelPop     bd        -> briDocSeqSpine bd
-  BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented
-  BDAlt             alts         -> foldl' (\() -> briDocSeqSpine) () alts
-  BDForwardLineMode bd           -> briDocSeqSpine bd
-  BDExternal{}                   -> ()
-  BDPlain{}                      -> ()
-  BDAnnotationPrior _annKey bd   -> briDocSeqSpine bd
-  BDAnnotationKW _annKey _kw bd  -> briDocSeqSpine bd
-  BDAnnotationRest _annKey bd    -> briDocSeqSpine bd
-  BDMoveToKWDP _annKey _kw _b bd -> briDocSeqSpine bd
-  BDLines lines                  -> foldl' (\() -> briDocSeqSpine) () lines
-  BDEnsureIndent _ind bd         -> briDocSeqSpine bd
-  BDForceMultiline  bd           -> briDocSeqSpine bd
-  BDForceSingleline bd           -> briDocSeqSpine bd
-  BDNonBottomSpacing _ bd        -> briDocSeqSpine bd
-  BDSetParSpacing   bd           -> briDocSeqSpine bd
-  BDForceParSpacing bd           -> briDocSeqSpine bd
-  BDDebug _s bd                  -> briDocSeqSpine bd
-
-briDocForceSpine :: BriDoc -> BriDoc
-briDocForceSpine bd = briDocSeqSpine bd `seq` bd
-
-
-data VerticalSpacingPar
-  = VerticalSpacingParNone -- no indented lines
-  | VerticalSpacingParSome   Int -- indented lines, requiring this much
-                                 -- vertical space at most
-  | VerticalSpacingParAlways Int -- indented lines, requiring this much
-                                 -- vertical space at most, but should
-                                 -- be considered as having space for
-                                 -- any spacing validity check.
-    -- TODO: it might be wrong not to extend "always" to the none case, i.e.
-    -- we might get better properties of spacing operators by having a
-    -- product like (Normal|Always, None|Some Int).
-  deriving (Eq, Show)
-
-data VerticalSpacing
-  = VerticalSpacing
-    { _vs_sameLine  :: !Int
-    , _vs_paragraph :: !VerticalSpacingPar
-    , _vs_parFlag   :: !Bool
-    }
-  deriving (Eq, Show)
-
-newtype LineModeValidity a = LineModeValidity (Strict.Maybe a)
-  deriving (Functor, Applicative, Monad, Show, Alternative)
-
-pattern LineModeValid :: forall t. t -> LineModeValidity t
-pattern LineModeValid x = LineModeValidity (Strict.Just x) :: LineModeValidity t
-pattern LineModeInvalid :: forall t. LineModeValidity t
-pattern LineModeInvalid = LineModeValidity Strict.Nothing :: LineModeValidity t

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

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

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

@@ -12,23 +12,23 @@ import qualified Data.Coerce
 import Data.Data
 import Data.Generics.Aliases
 import qualified Data.Generics.Uniplate.Direct as Uniplate
-import qualified Data.Semigroup as Semigroup
-import qualified Data.Sequence as Seq
 import DataTreePrint
 import qualified GHC.Data.FastString as GHC
-import qualified GHC.Driver.Session as GHC
-import qualified GHC.Hs.Extension as HsExtension
 import qualified GHC.OldList as List
-import GHC.Types.Name.Occurrence as OccName (occNameString)
+import           GHC.Types.Name.Occurrence            (OccName, occNameString)
+import qualified GHC.Types.Name.Reader as RdrName (rdrNameOcc)
 import qualified GHC.Types.SrcLoc as GHC
 import qualified GHC.Utils.Outputable as GHC
-import Language.Haskell.Brittany.Internal.Config.Types
+import qualified GHC.Parser.Annotation as GHC
-import Language.Haskell.Brittany.Internal.Prelude
-import Language.Haskell.Brittany.Internal.PreludeUtils
-import Language.Haskell.Brittany.Internal.Types
-import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
 import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
 import qualified Text.PrettyPrint as PP
+import qualified Data.Semigroup as Semigroup
+import qualified System.IO.Unsafe as Unsafe
+
+import Language.Haskell.Brittany.Internal.Prelude
+import Language.Haskell.Brittany.Internal.Components.BriDoc
+import Language.Haskell.Brittany.Internal.Types
+import Language.Haskell.Brittany.Internal.Config.Types
 
 
 
@@ -40,10 +40,10 @@ parDocW = PP.fsep . fmap PP.text . List.words . List.unwords
 
 
 showSDoc_ :: GHC.SDoc -> String
-showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags
+showSDoc_ = GHC.showSDocUnsafe
 
 showOutputable :: (GHC.Outputable a) => a -> String
-showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags
+showOutputable = GHC.showPprUnsafe
 
 fromMaybeIdentity :: Identity a -> Maybe a -> Identity a
 fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y
@@ -55,7 +55,7 @@ fromOptionIdentity x y =
 -- maximum monoid over N+0
 -- or more than N, because Num is allowed.
 newtype Max a = Max { getMax :: a }
-  deriving (Eq, Ord, Show, Bounded, Num)
+  deriving (Eq, Ord, Show, Num)
 
 instance (Num a, Ord a) => Semigroup (Max a) where
   (<>) = Data.Coerce.coerce (max :: a -> a -> a)
@@ -72,75 +72,112 @@ instance Show ShowIsId where
 data A x = A ShowIsId x
   deriving Data
 
-customLayouterF :: ExactPrint.Types.Anns -> LayouterF
+data DeltaComment = DeltaComment GHC.DeltaPos GHC.EpaCommentTok
-customLayouterF anns layoutF =
+  deriving Data
+
+customLayouterF :: LayouterF
+customLayouterF layoutF =
   DataToLayouter
     $ f
-    `extQ` showIsId
+    `extQ` internalLayouterShowIsId
-    `extQ` fastString
+    `extQ` internalLayouterFastString
-    `extQ` bytestring
+    `extQ` internalLayouterBytestring
-    `extQ` occName
+    `extQ` internalLayouterOccName
-    `extQ` srcSpan
+    `extQ` internalLayouterSrcSpan
-    `ext2Q` located
+    `extQ` internalLayouterRdrName
+    `extQ` realSrcSpan
+    -- `extQ` deltaComment
+    -- `extQ` anchored
+    -- `ext1Q` srcSpanAnn
+    -- `ext2Q` located
  where
   DataToLayouter f = defaultLayouterF layoutF
-  simpleLayouter :: String -> NodeLayouter
+  realSrcSpan :: GHC.RealSrcSpan -> NodeLayouter
-  simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s)
+  realSrcSpan span = internalLayouterSimple (show span)
-  showIsId :: ShowIsId -> NodeLayouter
+  -- anchored :: (Data b) => GHC.GenLocated GHC.Anchor b -> NodeLayouter
-  showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case
+  -- anchored (GHC.L (GHC.Anchor _ op) a) = f $ GHC.L op a
-    Left True -> PP.parens $ PP.text s
+
-    Left False -> PP.text s
+customLayouterNoSrcSpansF :: LayouterF
-    Right _ -> PP.text s
+customLayouterNoSrcSpansF layoutF =
-  fastString =
+  DataToLayouter
-    simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString
+    $ f
-      -> NodeLayouter
+    `extQ` internalLayouterShowIsId
-  bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter
+    `extQ` internalLayouterFastString
-  occName =
+    `extQ` internalLayouterBytestring
-    simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString
+    `extQ` internalLayouterOccName
-  srcSpan :: GHC.SrcSpan -> NodeLayouter
+    `extQ` internalLayouterSrcSpan
-  srcSpan ss =
+    `extQ` internalLayouterRdrName
-    simpleLayouter
+    `extQ` realSrcSpan
-             -- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}"
+    `extQ` deltaComment
-      $ "{"
+    `extQ` anchored
-      ++ showOutputable ss
+    `ext1Q` srcSpanAnn
-      ++ "}"
+    -- `ext2Q` located
-  located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter
+ where
-  located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a
+  DataToLayouter f = defaultLayouterF layoutF
-   where
+  realSrcSpan :: GHC.RealSrcSpan -> NodeLayouter
-    annStr = case cast ss of
+  realSrcSpan span = internalLayouterSimple (show span)
-      Just (s :: GHC.SrcSpan) ->
+  -- anchored :: (Data b) => GHC.GenLocated GHC.Anchor b -> NodeLayouter
-        ShowIsId $ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns)
+  -- anchored (GHC.L (GHC.Anchor _ op) a) = f $ GHC.L op a
-      Nothing -> ShowIsId "nnnnnnnn"
+  anchored :: GHC.Anchor -> NodeLayouter
+  anchored (GHC.Anchor _ op) = f op
+  srcSpanAnn :: forall a . Data a => GHC.SrcSpanAnn' a -> NodeLayouter
+  srcSpanAnn (GHC.SrcSpanAnn ann _loc) = f ann
+  deltaComment :: GHC.LEpaComment -> NodeLayouter
+  deltaComment (GHC.L anchor (GHC.EpaComment token prior)) =
+    f (GHC.L (ExactPrint.Utils.ss2deltaEnd prior (GHC.anchor anchor)) token)
+  -- located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter
+  -- located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a
+  --  where
+  --   annStr = case cast ss of
+  --     Just (s :: GHC.SrcSpan) ->
+  --       ShowIsId $ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns)
+  --     Nothing -> ShowIsId "nnnnnnnn"
 
 customLayouterNoAnnsF :: LayouterF
 customLayouterNoAnnsF layoutF =
   DataToLayouter
     $ f
-    `extQ` showIsId
+    `extQ` internalLayouterShowIsId
-    `extQ` fastString
+    `extQ` internalLayouterFastString
-    `extQ` bytestring
+    `extQ` internalLayouterBytestring
-    `extQ` occName
+    `extQ` internalLayouterOccName
-    `extQ` srcSpan
+    `extQ` internalLayouterSrcSpan
+    `extQ` internalLayouterRdrName
     `ext2Q` located
  where
   DataToLayouter f = defaultLayouterF layoutF
-  simpleLayouter :: String -> NodeLayouter
+  located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter
-  simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s)
+  located (GHC.L _ss a) = runDataToLayouter layoutF a
-  showIsId :: ShowIsId -> NodeLayouter
+
-  showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case
+internalLayouterSimple :: String -> NodeLayouter
+internalLayouterSimple s = NodeLayouter (length s) False (const $ PP.text s)
+internalLayouterShowIsId :: ShowIsId -> NodeLayouter
+internalLayouterShowIsId (ShowIsId s) =
+  NodeLayouter (length s + 2) True $ \case
     Left True -> PP.parens $ PP.text s
     Left False -> PP.text s
     Right _ -> PP.text s
-  fastString =
+internalLayouterFastString :: GHC.FastString -> NodeLayouter
-    simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString
+internalLayouterFastString =
-      -> NodeLayouter
+  internalLayouterSimple . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString
-  bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter
+    -> NodeLayouter
-  occName =
+internalLayouterBytestring :: B.ByteString -> NodeLayouter
-    simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString
+internalLayouterBytestring =
-  srcSpan :: GHC.SrcSpan -> NodeLayouter
+  internalLayouterSimple . show :: B.ByteString -> NodeLayouter
-  srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}"
+internalLayouterSrcSpan :: GHC.SrcSpan -> NodeLayouter
-  located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter
+internalLayouterSrcSpan ss =
-  located (GHC.L _ss a) = runDataToLayouter layoutF a
+    internalLayouterSimple
+             -- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}"
+      $ "{"
+      ++ showOutputable ss
+      ++ "}"
+internalLayouterOccName :: OccName -> NodeLayouter
+internalLayouterOccName =
+  internalLayouterSimple . ("{OccName: " ++) . (++ "}") . occNameString
+internalLayouterRdrName :: RdrName -> NodeLayouter
+internalLayouterRdrName =
+  internalLayouterSimple . ("{RdrName: " ++) . (++ "}") . occNameString . RdrName.rdrNameOcc
+
 
 -- displayBriDocTree :: BriDoc -> PP.Doc
 -- displayBriDocTree = \case
@@ -190,26 +227,19 @@ customLayouterNoAnnsF layoutF =
 --                               : [PP.text "," <+> displayBriDocSimpleTree t | t<-xr]
 --                              ++ [PP.text "]"]
 
-traceIfDumpConf
+-- traceWhen
-  :: (MonadMultiReader Config m, Show a)
+--   :: (Show a)
-  => String
+--   => String
-  -> (DebugConfig -> Identity (Semigroup.Last Bool))
+--   -> Bool
-  -> a
+--   -> a
-  -> m ()
+--   -> IO ()
-traceIfDumpConf s accessor val = do
+-- traceWhen s accessor val = do
-  whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do
+--   TraceFunc f <- mAsk
-    trace ("---- " ++ s ++ " ----\n" ++ show val) $ return ()
+--   whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do
+--     Unsafe.unsafePerformIO $ do
+--       f ("---- " ++ s ++ " ----\n" ++ show val)
+--       pure $ pure ()
 
-tellDebugMess :: MonadMultiWriter (Seq String) m => String -> m ()
-tellDebugMess s = mTell $ Seq.singleton s
-
-tellDebugMessShow
-  :: forall a m . (MonadMultiWriter (Seq String) m, Show a) => a -> m ()
-tellDebugMessShow = tellDebugMess . show
-
--- i should really put that into multistate..
-mModify :: MonadMultiState s m => (s -> s) -> m ()
-mModify f = mGet >>= mSet . f
 
 astToDoc :: Data ast => ast -> PP.Doc
 astToDoc ast = printTreeWithCustom 160 customLayouterNoAnnsF ast
@@ -218,17 +248,17 @@ briDocToDoc :: BriDoc -> PP.Doc
 briDocToDoc = astToDoc . removeAnnotations
  where
   removeAnnotations = Uniplate.transform $ \case
-    BDAnnotationPrior _ x -> x
+    BDFlushCommentsPrior _ x -> x
-    BDAnnotationKW _ _ x -> x
+    BDFlushCommentsPost _ x -> x
-    BDAnnotationRest _ x -> x
+    BDQueueComments _ x -> x
     x -> x
 
 briDocToDocWithAnns :: BriDoc -> PP.Doc
 briDocToDocWithAnns = astToDoc
 
-annsDoc :: ExactPrint.Types.Anns -> PP.Doc
+-- annsDoc :: ExactPrint.Types.Anns -> PP.Doc
-annsDoc =
+-- annsDoc =
-  printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show)
+--   printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show)
 
 breakEither :: (a -> Either b c) -> [a] -> ([b], [c])
 breakEither _ [] = ([], [])
@@ -252,17 +282,6 @@ splitFirstLast [] = FirstLastEmpty
 splitFirstLast [x] = FirstLastSingleton x
 splitFirstLast (x1 : xr) = FirstLast x1 (List.init xr) (List.last xr)
 
--- TODO: move to uniplate upstream?
--- aka `transform`
-transformUp :: Uniplate.Uniplate on => (on -> on) -> (on -> on)
-transformUp f = g where g = f . Uniplate.descend g
-_transformDown :: Uniplate.Uniplate on => (on -> on) -> (on -> on)
-_transformDown f = g where g = Uniplate.descend g . f
-transformDownMay :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on)
-transformDownMay f = g where g x = maybe x (Uniplate.descend g) $ f x
-_transformDownRec :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on)
-_transformDownRec f = g where g x = maybe (Uniplate.descend g x) g $ f x
-
 -- | similar to List.lines, but treating the case of final newline character
 -- in such a manner that this function is the inverse of @intercalate "\n"@.
 lines' :: String -> [String]
@@ -271,5 +290,18 @@ lines' s = case break (== '\n') s of
   (s1, [_]) -> [s1, ""]
   (s1, (_ : r)) -> s1 : lines' r
 
-absurdExt :: HsExtension.NoExtCon -> a
+-- absurdExt :: HsExtension.NoExtCon -> a
-absurdExt = HsExtension.noExtCon
+-- absurdExt = HsExtension.noExtCon
+
+traceIfDumpConf
+  :: (MonadMultiReader TraceFunc m, MonadMultiReader Config m, Show a)
+  => String
+  -> (DebugConfig -> Identity (Semigroup.Last Bool))
+  -> a
+  -> m ()
+traceIfDumpConf s accessor val = do
+  TraceFunc f <- mAsk
+  whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do
+    Unsafe.unsafePerformIO $ do
+      f ("---- " ++ s ++ " ----\n" ++ show val)
+      pure $ pure ()

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

@@ -1,33 +1,27 @@
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 
-module Language.Haskell.Brittany.Internal.Backend where
+module Language.Haskell.Brittany.Internal.WriteBriDoc.AlignmentAlgo
+  ( alignColsLines
+  )
+where
 
-import qualified Control.Monad.Trans.State.Strict as StateS
+import           Language.Haskell.Brittany.Internal.Prelude
-import qualified Data.Either as Either
+
-import qualified Data.Foldable as Foldable
+import qualified Control.Monad.Trans.State.Strict
-import qualified Data.IntMap.Lazy as IntMapL
+                                               as StateS
-import qualified Data.IntMap.Strict as IntMapS
+import qualified Data.Either                   as Either
-import qualified Data.Map as Map
+import qualified Data.Foldable                 as Foldable
-import qualified Data.Maybe as Maybe
+import qualified Data.IntMap.Lazy              as IntMapL
-import qualified Data.Semigroup as Semigroup
+import qualified Data.IntMap.Strict            as IntMapS
-import qualified Data.Sequence as Seq
+import qualified Data.Sequence                 as Seq
-import qualified Data.Set as Set
+import qualified Data.Text                     as Text
-import qualified Data.Text as Text
+import qualified GHC.OldList                   as List
-import qualified Data.Text.Lazy.Builder as Text.Builder
+
-import qualified GHC.OldList as List
+import           Language.Haskell.Brittany.Internal.Config.Types
-import Language.Haskell.Brittany.Internal.BackendUtils
+import           Language.Haskell.Brittany.Internal.Utils
-import Language.Haskell.Brittany.Internal.Config.Types
+import           Language.Haskell.Brittany.Internal.WriteBriDoc.Operators
-import Language.Haskell.Brittany.Internal.LayouterBasics
+import           Language.Haskell.Brittany.Internal.WriteBriDoc.Types
-import Language.Haskell.Brittany.Internal.Prelude
+import Language.Haskell.Brittany.Internal.Components.BriDoc
-import Language.Haskell.Brittany.Internal.PreludeUtils
-import Language.Haskell.Brittany.Internal.Types
-import Language.Haskell.Brittany.Internal.Utils
-import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
-import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
 
 
 
@@ -60,340 +54,10 @@ instance Show ColInfo where
     "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list
 
 data ColBuildState = ColBuildState
-  { _cbs_map :: ColMap1
+  { _cbs_map   :: ColMap1
   , _cbs_index :: ColIndex
   }
 
-type LayoutConstraints m
-  = ( MonadMultiReader Config m
-    , MonadMultiReader ExactPrint.Types.Anns m
-    , MonadMultiWriter Text.Builder.Builder m
-    , MonadMultiWriter (Seq String) m
-    , MonadMultiState LayoutState m
-    )
-
-layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m ()
-layoutBriDocM = \case
-  BDEmpty -> do
-    return () -- can it be that simple
-  BDLit t -> do
-    layoutIndentRestorePostComment
-    layoutRemoveIndentLevelLinger
-    layoutWriteAppend t
-  BDSeq list -> do
-    list `forM_` layoutBriDocM
-  -- in this situation, there is nothing to do about cols.
-  -- i think this one does not happen anymore with the current simplifications.
-  -- BDCols cSig list | BDPar sameLine lines <- List.last list ->
-  --   alignColsPar $ BDCols cSig (List.init list ++ [sameLine]) : lines
-  BDCols _ list -> do
-    list `forM_` layoutBriDocM
-  BDSeparator -> do
-    layoutAddSepSpace
-  BDAddBaseY indent bd -> do
-    let
-      indentF = case indent of
-        BrIndentNone -> id
-        BrIndentRegular -> layoutWithAddBaseCol
-        BrIndentSpecial i -> layoutWithAddBaseColN i
-    indentF $ layoutBriDocM bd
-  BDBaseYPushCur bd -> do
-    layoutBaseYPushCur
-    layoutBriDocM bd
-  BDBaseYPop bd -> do
-    layoutBriDocM bd
-    layoutBaseYPop
-  BDIndentLevelPushCur bd -> do
-    layoutIndentLevelPushCur
-    layoutBriDocM bd
-  BDIndentLevelPop bd -> do
-    layoutBriDocM bd
-    layoutIndentLevelPop
-  BDEnsureIndent indent bd -> do
-    let
-      indentF = case indent of
-        BrIndentNone -> id
-        BrIndentRegular -> layoutWithAddBaseCol
-        BrIndentSpecial i -> layoutWithAddBaseColN i
-    indentF $ do
-      layoutWriteEnsureBlock
-      layoutBriDocM bd
-  BDPar indent sameLine indented -> do
-    layoutBriDocM sameLine
-    let
-      indentF = case indent of
-        BrIndentNone -> id
-        BrIndentRegular -> layoutWithAddBaseCol
-        BrIndentSpecial i -> layoutWithAddBaseColN i
-    indentF $ do
-      layoutWriteNewlineBlock
-      layoutBriDocM indented
-  BDLines lines -> alignColsLines lines
-  BDAlt [] -> error "empty BDAlt"
-  BDAlt (alt : _) -> layoutBriDocM alt
-  BDForceMultiline bd -> layoutBriDocM bd
-  BDForceSingleline bd -> layoutBriDocM bd
-  BDForwardLineMode bd -> layoutBriDocM bd
-  BDExternal annKey subKeys shouldAddComment t -> do
-    let
-      tlines = Text.lines $ t <> Text.pack "\n"
-      tlineCount = length tlines
-    anns :: ExactPrint.Anns <- mAsk
-    when shouldAddComment $ do
-      layoutWriteAppend
-        $ Text.pack
-        $ "{-"
-        ++ show (annKey, Map.lookup annKey anns)
-        ++ "-}"
-    zip [1 ..] tlines `forM_` \(i, l) -> do
-      layoutWriteAppend $ l
-      unless (i == tlineCount) layoutWriteNewlineBlock
-    do
-      state <- mGet
-      let filterF k _ = not $ k `Set.member` subKeys
-      mSet $ state
-        { _lstate_comments = Map.filterWithKey filterF $ _lstate_comments state
-        }
-  BDPlain t -> do
-    layoutWriteAppend t
-  BDAnnotationPrior annKey bd -> do
-    state <- mGet
-    let m = _lstate_comments state
-    let
-      moveToExactLocationAction = case _lstate_curYOrAddNewline state of
-        Left{} -> pure ()
-        Right{} -> moveToExactAnn annKey
-    mAnn <- do
-      let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m
-      mSet $ state
-        { _lstate_comments = Map.adjust
-          (\ann -> ann { ExactPrint.annPriorComments = [] })
-          annKey
-          m
-        }
-      return mAnn
-    case mAnn of
-      Nothing -> moveToExactLocationAction
-      Just [] -> moveToExactLocationAction
-      Just priors -> do
-        -- layoutResetSepSpace
-        priors
-          `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
-                    when (comment /= "(" && comment /= ")") $ do
-                      let commentLines = Text.lines $ Text.pack $ comment
-                      case comment of
-                        ('#' : _) ->
-                          layoutMoveToCommentPos y (-999) (length commentLines)
-                                   --  ^ evil hack for CPP
-                        _ -> layoutMoveToCommentPos y x (length commentLines)
-                      -- fixedX <- fixMoveToLineByIsNewline x
-                      -- replicateM_ fixedX layoutWriteNewline
-                      -- layoutMoveToIndentCol y
-                      layoutWriteAppendMultiline commentLines
-          -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
-        moveToExactLocationAction
-    layoutBriDocM bd
-  BDAnnotationKW annKey keyword bd -> do
-    layoutBriDocM bd
-    mComments <- do
-      state <- mGet
-      let m = _lstate_comments state
-      let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
-      let
-        mToSpan = case mAnn of
-          Just anns | Maybe.isNothing keyword -> Just anns
-          Just ((ExactPrint.Types.G kw1, _) : annR) | keyword == Just kw1 ->
-            Just annR
-          _ -> Nothing
-      case mToSpan of
-        Just anns -> do
-          let
-            (comments, rest) = flip spanMaybe anns $ \case
-              (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp)
-              _ -> Nothing
-          mSet $ state
-            { _lstate_comments = Map.adjust
-              (\ann -> ann { ExactPrint.annsDP = rest })
-              annKey
-              m
-            }
-          return $ nonEmpty comments
-        _ -> return Nothing
-    case mComments of
-      Nothing -> pure ()
-      Just comments -> do
-        comments
-          `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
-                    when (comment /= "(" && comment /= ")") $ do
-                      let commentLines = Text.lines $ Text.pack $ comment
-                      -- evil hack for CPP:
-                      case comment of
-                        ('#' : _) ->
-                          layoutMoveToCommentPos y (-999) (length commentLines)
-                        _ -> layoutMoveToCommentPos y x (length commentLines)
-                      -- fixedX <- fixMoveToLineByIsNewline x
-                      -- replicateM_ fixedX layoutWriteNewline
-                      -- layoutMoveToIndentCol y
-                      layoutWriteAppendMultiline commentLines
-      -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
-  BDAnnotationRest annKey bd -> do
-    layoutBriDocM bd
-    annMay <- do
-      state <- mGet
-      let m = _lstate_comments state
-      pure $ Map.lookup annKey m
-    let mComments = nonEmpty . extractAllComments =<< annMay
-    let
-      semiCount = length
-        [ ()
-        | Just ann <- [annMay]
-        , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann
-        ]
-    shouldAddSemicolonNewlines <-
-      mAsk
-      <&> _conf_layout
-      .> _lconfig_experimentalSemicolonNewlines
-      .> confUnpack
-    mModify $ \state -> state
-      { _lstate_comments = Map.adjust
-        (\ann -> ann
-          { ExactPrint.annFollowingComments = []
-          , ExactPrint.annPriorComments = []
-          , ExactPrint.annsDP = flip filter (ExactPrint.annsDP ann) $ \case
-            (ExactPrint.Types.AnnComment{}, _) -> False
-            _ -> True
-          }
-        )
-        annKey
-        (_lstate_comments state)
-      }
-    case mComments of
-      Nothing -> do
-        when shouldAddSemicolonNewlines $ do
-          [1 .. semiCount] `forM_` const layoutWriteNewline
-      Just comments -> do
-        comments
-          `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
-                    when (comment /= "(" && comment /= ")") $ do
-                      let commentLines = Text.lines $ Text.pack comment
-                      case comment of
-                        ('#' : _) -> layoutMoveToCommentPos y (-999) 1
-                                   --  ^ evil hack for CPP
-                        ")" -> pure ()
-                                   --  ^ fixes the formatting of parens
-                                   --    on the lhs of type alias defs
-                        _ -> layoutMoveToCommentPos y x (length commentLines)
-                      -- fixedX <- fixMoveToLineByIsNewline x
-                      -- replicateM_ fixedX layoutWriteNewline
-                      -- layoutMoveToIndentCol y
-                      layoutWriteAppendMultiline commentLines
-      -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
-  BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do
-    mDP <- do
-      state <- mGet
-      let m = _lstate_comments state
-      let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
-      let
-        relevant =
-          [ dp
-          | Just ann <- [mAnn]
-          , (ExactPrint.Types.G kw1, dp) <- ann
-          , keyword == kw1
-          ]
-      -- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant]
-      case relevant of
-        [] -> pure Nothing
-        (ExactPrint.Types.DP (y, x) : _) -> do
-          mSet state { _lstate_commentNewlines = 0 }
-          pure $ Just (y - _lstate_commentNewlines state, x)
-    case mDP of
-      Nothing -> pure ()
-      Just (y, x) ->
-        -- we abuse this, as we probably will print the KW next, which is
-        -- _not_ a comment..
-        layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) 1
-    layoutBriDocM bd
-  BDNonBottomSpacing _ bd -> layoutBriDocM bd
-  BDSetParSpacing bd -> layoutBriDocM bd
-  BDForceParSpacing bd -> layoutBriDocM bd
-  BDDebug s bd -> do
-    mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}"
-    layoutBriDocM bd
-
-briDocLineLength :: BriDoc -> Int
-briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc
-                          -- the state encodes whether a separator was already
-                          -- appended at the current position.
- where
-  rec = \case
-    BDEmpty -> return $ 0
-    BDLit t -> StateS.put False $> Text.length t
-    BDSeq bds -> sum <$> rec `mapM` bds
-    BDCols _ bds -> sum <$> rec `mapM` bds
-    BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1
-    BDAddBaseY _ bd -> rec bd
-    BDBaseYPushCur bd -> rec bd
-    BDBaseYPop bd -> rec bd
-    BDIndentLevelPushCur bd -> rec bd
-    BDIndentLevelPop bd -> rec bd
-    BDPar _ line _ -> rec line
-    BDAlt{} -> error "briDocLineLength BDAlt"
-    BDForceMultiline bd -> rec bd
-    BDForceSingleline bd -> rec bd
-    BDForwardLineMode bd -> rec bd
-    BDExternal _ _ _ t -> return $ Text.length t
-    BDPlain t -> return $ Text.length t
-    BDAnnotationPrior _ bd -> rec bd
-    BDAnnotationKW _ _ bd -> rec bd
-    BDAnnotationRest _ bd -> rec bd
-    BDMoveToKWDP _ _ _ bd -> rec bd
-    BDLines ls@(_ : _) -> do
-      x <- StateS.get
-      return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x
-    BDLines [] -> error "briDocLineLength BDLines []"
-    BDEnsureIndent _ bd -> rec bd
-    BDSetParSpacing bd -> rec bd
-    BDForceParSpacing bd -> rec bd
-    BDNonBottomSpacing _ bd -> rec bd
-    BDDebug _ bd -> rec bd
-
-briDocIsMultiLine :: BriDoc -> Bool
-briDocIsMultiLine briDoc = rec briDoc
- where
-  rec :: BriDoc -> Bool
-  rec = \case
-    BDEmpty -> False
-    BDLit _ -> False
-    BDSeq bds -> any rec bds
-    BDCols _ bds -> any rec bds
-    BDSeparator -> False
-    BDAddBaseY _ bd -> rec bd
-    BDBaseYPushCur bd -> rec bd
-    BDBaseYPop bd -> rec bd
-    BDIndentLevelPushCur bd -> rec bd
-    BDIndentLevelPop bd -> rec bd
-    BDPar{} -> True
-    BDAlt{} -> error "briDocIsMultiLine BDAlt"
-    BDForceMultiline _ -> True
-    BDForceSingleline bd -> rec bd
-    BDForwardLineMode bd -> rec bd
-    BDExternal _ _ _ t | [_] <- Text.lines t -> False
-    BDExternal{} -> True
-    BDPlain t | [_] <- Text.lines t -> False
-    BDPlain _ -> True
-    BDAnnotationPrior _ bd -> rec bd
-    BDAnnotationKW _ _ bd -> rec bd
-    BDAnnotationRest _ bd -> rec bd
-    BDMoveToKWDP _ _ _ bd -> rec bd
-    BDLines (_ : _ : _) -> True
-    BDLines [_] -> False
-    BDLines [] -> error "briDocIsMultiLine BDLines []"
-    BDEnsureIndent _ bd -> rec bd
-    BDSetParSpacing bd -> rec bd
-    BDForceParSpacing bd -> rec bd
-    BDNonBottomSpacing _ bd -> rec bd
-    BDDebug _ bd -> rec bd
-
 -- In theory
 -- =========
 
@@ -469,25 +133,26 @@ briDocIsMultiLine briDoc = rec briDoc
 -- are executed in the same recursion, too.
 -- Also, _lconfig_alignmentLimit really is itself a hack that hides the issue
 -- mentioned in the first "possible improvement".
-alignColsLines :: LayoutConstraints m => [BriDoc] -> m ()
+alignColsLines :: LayoutConstraints m => (BriDoc -> m ()) -> [BriDoc] -> m ()
-alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
+alignColsLines layoutBriDocM bridocs = do -- colInfos `forM_` \colInfo -> do
   -- tellDebugMess ("alignColsLines: at " ++ take 100 (show $ briDocToDoc $ head bridocs))
   curX <- do
     state <- mGet
     return $ Either.fromLeft 0 (_lstate_curYOrAddNewline state) + fromMaybe
       0
       (_lstate_addSepSpace state)
-  colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack
+  colMax     <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack
-  alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack
+  alignMax   <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack
   alignBreak <-
     mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack
   case () of
     _ -> do
+      -- tellDebugMess ("colInfos:\n" ++ List.unlines [ "> " ++ prettyColInfos "> " x | x <- colInfos])
       -- tellDebugMess ("processedMap: " ++ show processedMap)
       sequence_
-        $ List.intersperse layoutWriteEnsureNewlineBlock
+        $   List.intersperse layoutWriteEnsureNewlineBlock
-        $ colInfos
+        $   colInfos
-        <&> processInfo colMax processedMap
+        <&> processInfo layoutBriDocM colMax processedMap
      where
       (colInfos, finalState) =
         StateS.runState (mergeBriDocs bridocs) (ColBuildState IntMapS.empty 0)
@@ -511,11 +176,11 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
               (xN : xR) ->
                 reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR
              where
-              fLast (ColumnSpacingLeaf len) = len
+              fLast (ColumnSpacingLeaf len ) = len
               fLast (ColumnSpacingRef len _) = len
               fInit (ColumnSpacingLeaf len) = len
-              fInit (ColumnSpacingRef _ i) = case IntMapL.lookup i result of
+              fInit (ColumnSpacingRef _ i ) = case IntMapL.lookup i result of
-                Nothing -> 0
+                Nothing           -> 0
                 Just (_, maxs, _) -> sum maxs
             maxCols = {-Foldable.foldl1 maxZipper-}
               fmap colAggregation $ transpose $ Foldable.toList colss
@@ -524,18 +189,19 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
             counter count l = if List.last posXs + List.last l <= colMax
               then count + 1
               else count
-            ratio = fromIntegral (foldl counter (0 :: Int) colss)
+            ratio = fromIntegral (foldl' counter (0 :: Int) colss)
               / fromIntegral (length colss)
-          in (ratio, maxCols, colss)
+          in
+            (ratio, maxCols, colss)
 
       mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo]
       mergeBriDocs bds = mergeBriDocsW ColInfoStart bds
 
       mergeBriDocsW
         :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo]
-      mergeBriDocsW _ [] = return []
+      mergeBriDocsW _        []         = return []
       mergeBriDocsW lastInfo (bd : bdr) = do
-        info <- mergeInfoBriDoc True lastInfo bd
+        info  <- mergeInfoBriDoc True lastInfo bd
         infor <- mergeBriDocsW
           -- (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info)
           (if shouldBreakAfter bd then ColInfoStart else info)
@@ -591,7 +257,7 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
         -> BriDoc
         -> StateS.StateT ColBuildState Identity ColInfo
       mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag
-      mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag
+      mergeInfoBriDoc lastFlag ColInfoNo{}  = briDocToColInfo lastFlag
       mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) =
         \case
           brdc@(BDCols colSig subDocs)
@@ -602,56 +268,26 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
                   else repeat False
               infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs
                 `forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd
-              let curLengths = briDocLineLength <$> subDocs
+              let curLengths   = briDocLineLength <$> subDocs
               let trueSpacings = getTrueSpacings (zip curLengths infos)
               do -- update map
                 s <- StateS.get
                 let m = _cbs_map s
-                let (Just (_, spaces)) = IntMapS.lookup infoInd m
+                case IntMapS.lookup infoInd m of
-                StateS.put s
+                  Just (_, spaces) -> StateS.put s
-                  { _cbs_map = IntMapS.insert
+                    { _cbs_map = IntMapS.insert
-                    infoInd
+                                   infoInd
-                    (lastFlag, spaces Seq.|> trueSpacings)
+                                   (lastFlag, spaces Seq.|> trueSpacings)
-                    m
+                                   m
-                  }
+                    }
+                  Nothing -> pure () -- shouldn't be possible
               return $ ColInfo infoInd colSig (zip curLengths infos)
             | otherwise -> briDocToColInfo lastFlag brdc
           brdc -> return $ ColInfoNo brdc
 
-briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo
-briDocToColInfo lastFlag = \case
-  BDCols sig list -> withAlloc lastFlag $ \ind -> do
-    let
-      isLastList =
-        if lastFlag then (== length list) <$> [1 ..] else repeat False
-    subInfos <- zip isLastList list `forM` uncurry briDocToColInfo
-    let lengthInfos = zip (briDocLineLength <$> list) subInfos
-    let trueSpacings = getTrueSpacings lengthInfos
-    return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos)
-  bd -> return $ ColInfoNo bd
 
-getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing]
+processInfo :: LayoutConstraints m => (BriDoc -> m ()) -> Int -> ColMap2 -> ColInfo -> m ()
-getTrueSpacings lengthInfos = lengthInfos <&> \case
+processInfo layoutBriDocM maxSpace m = \case
-  (len, ColInfo i _ _) -> ColumnSpacingRef len i
-  (len, _) -> ColumnSpacingLeaf len
-
-withAlloc
-  :: Bool
-  -> ( ColIndex
-     -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo)
-     )
-  -> StateS.State ColBuildState ColInfo
-withAlloc lastFlag f = do
-  cbs <- StateS.get
-  let ind = _cbs_index cbs
-  StateS.put $ cbs { _cbs_index = ind + 1 }
-  (space, info) <- f ind
-  StateS.get >>= \c -> StateS.put
-    $ c { _cbs_map = IntMapS.insert ind (lastFlag, space) $ _cbs_map c }
-  return info
-
-processInfo :: LayoutConstraints m => Int -> ColMap2 -> ColInfo -> m ()
-processInfo maxSpace m = \case
   ColInfoStart -> error "should not happen (TM)"
   ColInfoNo doc -> layoutBriDocM doc
   ColInfo ind _ list -> -- trace ("processInfo ind=" ++ show ind ++ ", list=" ++ show list ++ ", colmap=" ++ show m) $
@@ -660,7 +296,9 @@ processInfo maxSpace m = \case
     alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack
     curX <- do
       state <- mGet
-      -- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state)))
+      -- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state)
+      --                       ++ " - " ++ show (_lstate_addSepSpace state)
+      --                       ++ " - " ++ show (_lstate_commentCol state))
       let spaceAdd = fromMaybe 0 $ _lstate_addSepSpace state
       return $ case _lstate_curYOrAddNewline state of
         Left i -> case _lstate_commentCol state of
@@ -669,11 +307,12 @@ processInfo maxSpace m = \case
         Right{} -> spaceAdd
     let colMax = min colMaxConf (curX + maxSpace)
     -- tellDebugMess $ show curX
-    let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m
+    let (ratio, maxCols1, _colss) = case IntMapS.lookup ind m of
+          Just x -> x
+          Nothing -> error "internal brittany error: processInfo bad lookup"
     let
       maxCols2 = list <&> \case
-        (_, ColInfo i _ _) ->
+        (_, ColInfo i _ _) | Just (_, ms, _) <- IntMapS.lookup i m -> sum ms
-          let Just (_, ms, _) = IntMapS.lookup i m in sum ms
         (l, _) -> l
     let maxCols = zipWith max maxCols1 maxCols2
     let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols
@@ -701,18 +340,20 @@ processInfo maxSpace m = \case
       spacings =
         zipWith (-) (List.tail fixedPosXs ++ [min maxX colMax]) fixedPosXs
     -- tellDebugMess $ "ind = " ++ show ind
+    -- tellDebugMess $ "spacings = " ++ show spacings
     -- tellDebugMess $ "maxCols = " ++ show maxCols
     -- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs
     -- tellDebugMess $ "list = " ++ show list
     -- tellDebugMess $ "maxSpace = " ++ show maxSpace
     let
       alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do
+        -- tellDebugMess $ "layoutWriteEnsureAbsoluteN " ++ show destX
         layoutWriteEnsureAbsoluteN destX
-        processInfo s m (snd x)
+        processInfo layoutBriDocM s m (snd x)
-      noAlignAct = list `forM_` (snd .> processInfoIgnore)
+      noAlignAct = list `forM_` (snd .> processInfoIgnore layoutBriDocM)
-      animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $
+      animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax=" ++ show colMax) $
                    if List.last fixedPosXs + fst (List.last list) > colMax
-                                                                                                                                                                   -- per-item check if there is overflowing.
+                                                                                                                                                                                                                                                                                                                   -- per-item check if there is overflowing.
         then noAlignAct
         else alignAct
     case alignMode of
@@ -725,8 +366,145 @@ processInfo maxSpace m = \case
       ColumnAlignModeAnimously -> animousAct
       ColumnAlignModeAlways -> alignAct
 
-processInfoIgnore :: LayoutConstraints m => ColInfo -> m ()
+
-processInfoIgnore = \case
+getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing]
-  ColInfoStart -> error "should not happen (TM)"
+getTrueSpacings lengthInfos = lengthInfos <&> \case
-  ColInfoNo doc -> layoutBriDocM doc
+  (len, ColInfo i _ _) -> ColumnSpacingRef len i
-  ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore)
+  (len, _) -> ColumnSpacingLeaf len
+
+withAlloc
+  :: Bool
+  -> ( ColIndex
+     -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo)
+     )
+  -> StateS.State ColBuildState ColInfo
+withAlloc lastFlag f = do
+  cbs <- StateS.get
+  let ind = _cbs_index cbs
+  StateS.put $ cbs { _cbs_index = ind + 1 }
+  (space, info) <- f ind
+  StateS.get >>= \c -> StateS.put
+    $ c { _cbs_map = IntMapS.insert ind (lastFlag, space) $ _cbs_map c }
+  return info
+
+briDocLineLength :: BriDoc -> Int
+briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc
+                          -- the state encodes whether a separator was already
+                          -- appended at the current position.
+ where
+  rec = \case
+    BDEmpty -> return $ 0
+    BDLit t -> StateS.put False $> Text.length t
+    BDSeq bds -> sum <$> rec `mapM` bds
+    BDCols _ bds -> sum <$> rec `mapM` bds
+    BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1
+    BDAddBaseY _ bd -> rec bd
+    BDBaseYPushCur bd -> rec bd
+    BDBaseYPop bd -> rec bd
+    BDIndentLevelPushCur bd -> rec bd
+    BDIndentLevelPop bd -> rec bd
+    BDPar _ line _ -> rec line
+    BDAlt{} -> error "briDocLineLength BDAlt"
+    BDForceMultiline bd -> rec bd
+    BDForceSingleline bd -> rec bd
+    BDForwardLineMode bd -> rec bd
+    BDExternal _ t -> return $ Text.length t
+    BDPlain t -> return $ Text.length t
+    BDQueueComments _ bd -> rec bd
+    BDFlushCommentsPrior _ bd -> rec bd
+    BDFlushCommentsPost _ bd -> rec bd
+    BDLines ls@(_ : _) -> do
+      x <- StateS.get
+      return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x
+    BDLines [] -> error "briDocLineLength BDLines []"
+    BDEnsureIndent _ bd -> rec bd
+    BDSetParSpacing bd -> rec bd
+    BDForceParSpacing bd -> rec bd
+    BDNonBottomSpacing _ bd -> rec bd
+    BDDebug _ bd -> rec bd
+
+briDocIsMultiLine :: BriDoc -> Bool
+briDocIsMultiLine briDoc = rec briDoc
+ where
+  rec :: BriDoc -> Bool
+  rec = \case
+    BDEmpty -> False
+    BDLit _ -> False
+    BDSeq bds -> any rec bds
+    BDCols _ bds -> any rec bds
+    BDSeparator -> False
+    BDAddBaseY _ bd -> rec bd
+    BDBaseYPushCur bd -> rec bd
+    BDBaseYPop bd -> rec bd
+    BDIndentLevelPushCur bd -> rec bd
+    BDIndentLevelPop bd -> rec bd
+    BDPar{} -> True
+    BDAlt{} -> error "briDocIsMultiLine BDAlt"
+    BDForceMultiline _ -> True
+    BDForceSingleline bd -> rec bd
+    BDForwardLineMode bd -> rec bd
+    BDExternal _ t | [_] <- Text.lines t -> False
+    BDExternal{} -> True
+    BDPlain t | [_] <- Text.lines t -> False
+    BDPlain _ -> True
+    BDQueueComments _ bd -> rec bd
+    BDFlushCommentsPrior _ bd -> rec bd
+    BDFlushCommentsPost _ bd -> rec bd
+    BDLines (_ : _ : _) -> True
+    BDLines [_] -> False
+    BDLines [] -> error "briDocIsMultiLine BDLines []"
+    BDEnsureIndent _ bd -> rec bd
+    BDSetParSpacing bd -> rec bd
+    BDForceParSpacing bd -> rec bd
+    BDNonBottomSpacing _ bd -> rec bd
+    BDDebug _ bd -> rec bd
+
+briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo
+briDocToColInfo lastFlag = \case
+  BDCols sig list -> withAlloc lastFlag $ \ind -> do
+    let
+      isLastList =
+        if lastFlag then (== length list) <$> [1 ..] else repeat False
+    subInfos <- zip isLastList list `forM` uncurry briDocToColInfo
+    let lengthInfos = zip (briDocLineLength <$> list) subInfos
+    let trueSpacings = getTrueSpacings lengthInfos
+    return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos)
+  bd -> return $ ColInfoNo bd
+
+processInfoIgnore :: LayoutConstraints m => (BriDoc -> m ()) -> ColInfo -> m ()
+processInfoIgnore layoutBriDocM = go
+ where
+  go = \case
+    ColInfoStart     -> error "should not happen (TM)"
+    ColInfoNo doc    -> layoutBriDocM doc
+    ColInfo _ _ list -> list `forM_` (snd .> go)
+
+
+_prettyColInfos :: String -> ColInfo -> String
+_prettyColInfos prefix = \case
+  ColInfoStart -> "start (?)"
+  ColInfoNo bd -> "X" ++ replicate (briDocLineLength bd - 1) '_'
+  ColInfo _ind sig below ->
+    let
+      (total, belowStrs) = List.mapAccumL
+        (\x (add, info) ->
+          (x + add, _prettyColInfos (prefix ++ replicate (x) ' ') info)
+        )
+        0
+        below
+    in
+      "X"
+      ++ replicate (total - 1) 'x'
+      ++ " as "
+      ++ show sig
+      ++ " "
+      ++ show _ind
+      ++ "\n"
+      ++ prefix
+      ++ List.concat belowStrs
+      ++ "\n"
+      ++ prefix
+      ++ replicate total ' '
+    -- [ prefix ++ show k ++ ": " ++ prettyColInfos (prefix ++ "  ") v
+    -- | (k, v) <- below
+    -- ]

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

@@ -1,29 +1,24 @@
-{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
-module Language.Haskell.Brittany.Internal.BackendUtils where
+module Language.Haskell.Brittany.Internal.WriteBriDoc.Operators where
 
-import qualified Data.Data
-import qualified Data.Either
-import qualified Data.Map as Map
-import qualified Data.Maybe
-import qualified Data.Semigroup as Semigroup
-import qualified Data.Text as Text
-import qualified Data.Text.Lazy.Builder as Text.Builder
-import GHC (Located)
-import qualified GHC.OldList as List
-import Language.Haskell.Brittany.Internal.Config.Types
 import Language.Haskell.Brittany.Internal.Prelude
-import Language.Haskell.Brittany.Internal.PreludeUtils
+
-import Language.Haskell.Brittany.Internal.Types
+import qualified Data.Maybe
-import Language.Haskell.Brittany.Internal.Utils
+import qualified Data.Text                     as Text
-import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation)
+import qualified Data.Text.Lazy.Builder        as Text.Builder
-import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
+import qualified GHC.OldList                   as List
+import qualified GHC.Parser.Annotation         as GHC
+
+import           Language.Haskell.Brittany.Internal.Config.Types
+import           Language.Haskell.Brittany.Internal.WriteBriDoc.Types
 
 
 
 traceLocal :: (MonadMultiState LayoutState m) => a -> m ()
 traceLocal _ = return ()
+-- traceLocal :: (MonadMultiState LayoutState m, Show a) => a -> m ()
+-- traceLocal x = trace (show x) $ pure ()
 
 
 layoutWriteAppend
@@ -31,8 +26,8 @@ layoutWriteAppend
   => Text
   -> m ()
 layoutWriteAppend t = do
-  traceLocal ("layoutWriteAppend", t)
   state <- mGet
+  traceLocal ("layoutWriteAppend", t, _lstate_curYOrAddNewline state, _lstate_addSepSpace state)
   case _lstate_curYOrAddNewline state of
     Right i -> do
       replicateM_ i $ mTell $ Text.Builder.fromString $ "\n"
@@ -115,23 +110,31 @@ layoutSetCommentCol = do
 -- to be harmless so far..
 layoutMoveToCommentPos
   :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
-  => Int
+  => Bool
+  -> Int
   -> Int
   -> Int
   -> m ()
-layoutMoveToCommentPos y x commentLines = do
+layoutMoveToCommentPos absolute y x commentLines = do
-  traceLocal ("layoutMoveToCommentPos", y, x, commentLines)
   state <- mGet
+  traceLocal ("layoutMoveToCommentPos", y, x, commentLines, _lstate_curYOrAddNewline state, _lstate_addSepSpace state, lstate_baseY state)
   mSet state
     { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
       Left i -> if y == 0 then Left i else Right y
       Right{} -> Right y
     , _lstate_addSepSpace =
-      Just $ if Data.Maybe.isJust (_lstate_commentCol state)
+      Just $ if 
-        then case _lstate_curYOrAddNewline state of
+        | y > 0 -> if absolute then x - 1 else lstate_baseY state + x
-          Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x
+        | Data.Maybe.isNothing (_lstate_commentCol state) -> x
-          Right{} -> _lstate_indLevelLinger state + x
+        | otherwise -> x
-        else if y == 0 then x else _lstate_indLevelLinger state + x
+          -- TODO92 we had more complex logic here for otherwise previously,
+          -- but I don't think it can happen. Leaving this here until some
+          -- more testing is done as a reminder.
+          -- Also, if this _is_ necessary, the "absolute" handling might to
+          -- be adapted.
+          -- case _lstate_curYOrAddNewline state of
+          -- Left{} -> x
+          -- Right{} -> _lstate_indLevelLinger state + x
     , _lstate_commentCol = Just $ case _lstate_commentCol state of
       Just existing -> existing
       Nothing -> case _lstate_curYOrAddNewline state of
@@ -163,8 +166,8 @@ layoutWriteEnsureNewlineBlock
   :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
   => m ()
 layoutWriteEnsureNewlineBlock = do
-  traceLocal ("layoutWriteEnsureNewlineBlock")
   state <- mGet
+  traceLocal ("layoutWriteEnsureNewlineBlock", lstate_baseY state)
   mSet $ state
     { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
       Left{} -> Right 1
@@ -292,15 +295,20 @@ layoutWithAddBaseColN amount m = do
 
 layoutBaseYPushCur :: (MonadMultiState LayoutState m) => m ()
 layoutBaseYPushCur = do
-  traceLocal ("layoutBaseYPushCur")
   state <- mGet
-  case _lstate_commentCol state of
+  traceLocal
-    Nothing ->
+    ( "layoutBaseYPushCur"
-      case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
+    , _lstate_curYOrAddNewline state
-        (Left i, Just j) -> layoutBaseYPushInternal (i + j)
+    , _lstate_addSepSpace state
-        (Left i, Nothing) -> layoutBaseYPushInternal i
+    )
-        (Right{}, _) -> layoutBaseYPushInternal $ lstate_baseY state
+  layoutBaseYPushInternal
-    Just cCol -> layoutBaseYPushInternal cCol
+    (case _lstate_commentCol state of
+      Nothing -> case _lstate_curYOrAddNewline state of
+        Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
+        Right{} -> lstate_baseY state
+      Just cCol -> cCol + fromMaybe 0 (_lstate_addSepSpace state)
+    )
+
 
 layoutBaseYPop :: (MonadMultiState LayoutState m) => m ()
 layoutBaseYPop = do
@@ -338,39 +346,48 @@ layoutAddSepSpace = do
 
 -- TODO: when refactoring is complete, the other version of this method
 -- can probably be removed.
-moveToExactAnn
+-- moveToExactAnn
-  :: ( MonadMultiWriter Text.Builder.Builder m
+--   :: ( MonadMultiWriter Text.Builder.Builder m
-     , MonadMultiState LayoutState m
+--      , MonadMultiState LayoutState m
-     , MonadMultiReader (Map AnnKey Annotation) m
+--      , MonadMultiReader (Map AnnKey Annotation) m
-     )
+--      )
-  => AnnKey
+--   => AnnKey
-  -> m ()
+--   -> m ()
-moveToExactAnn annKey = do
+-- moveToExactAnn annKey = do
-  traceLocal ("moveToExactAnn", annKey)
+--   traceLocal ("moveToExactAnn", annKey)
-  anns <- mAsk
+--   anns <- mAsk
-  case Map.lookup annKey anns of
+--   case Map.lookup annKey anns of
-    Nothing -> return ()
+--     Nothing -> return ()
-    Just ann -> do
+--     Just ann -> do
-      -- curY <- mGet <&> _lstate_curY
+--       -- curY <- mGet <&> _lstate_curY
-      let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann
+--       let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann
-      -- mModify $ \state -> state { _lstate_addNewline = Just x }
+--       -- mModify $ \state -> state { _lstate_addNewline = Just x }
-      moveToY y
+--       moveToY y
 
-moveToY :: MonadMultiState LayoutState m => Int -> m ()
+moveToCommentPos
-moveToY y = mModify $ \state ->
+  :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
-  let
+  => Bool
-    upd = case _lstate_curYOrAddNewline state of
+  -> GHC.DeltaPos
-      Left i -> if y == 0 then Left i else Right y
+  -> m ()
-      Right i -> Right $ max y i
+moveToCommentPos absolute = \case
-  in
+  GHC.SameLine c -> layoutMoveToCommentPos absolute 0 c 1
-    state
+  GHC.DifferentLine l c -> layoutMoveToCommentPos absolute l c 1
-      { _lstate_curYOrAddNewline = upd
+
-      , _lstate_addSepSpace = if Data.Either.isRight upd
+-- moveToY :: MonadMultiState LayoutState m => Int -> m ()
-        then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just
+-- moveToY y = mModify $ \state ->
-          (lstate_baseY state)
+--   let
-        else Nothing
+--     upd = case _lstate_curYOrAddNewline state of
-      , _lstate_commentCol = Nothing
+--       Left i -> if y == 0 then Left i else Right y
-      }
+--       Right i -> Right $ max y i
+--   in
+--     state
+--       { _lstate_curYOrAddNewline = upd
+--       , _lstate_addSepSpace = if Data.Either.isRight upd
+--         then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just
+--           (lstate_baseY state)
+--         else Nothing
+--       , _lstate_commentCol = Nothing
+--       }
 -- fixMoveToLineByIsNewline :: MonadMultiState
 --                                                   LayoutState m => Int -> m Int
 -- fixMoveToLineByIsNewline x = do
@@ -379,77 +396,71 @@ moveToY y = mModify $ \state ->
 --     then x-1
 --     else x
 
-ppmMoveToExactLoc
-  :: MonadMultiWriter Text.Builder.Builder m => ExactPrint.DeltaPos -> m ()
-ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do
-  replicateM_ x $ mTell $ Text.Builder.fromString "\n"
-  replicateM_ y $ mTell $ Text.Builder.fromString " "
-
 -- TODO: update and use, or clean up. Currently dead code.
-layoutWritePriorComments
+-- layoutWritePriorComments
-  :: ( Data.Data.Data ast
+--   :: ( Data.Data.Data ast
-     , MonadMultiWriter Text.Builder.Builder m
+--      , MonadMultiWriter Text.Builder.Builder m
-     , MonadMultiState LayoutState m
+--      , MonadMultiState LayoutState m
-     )
+--      )
-  => Located ast
+--   => Located ast
-  -> m ()
+--   -> m ()
-layoutWritePriorComments ast = do
+-- layoutWritePriorComments ast = do
-  mAnn <- do
+--   mAnn <- do
-    state <- mGet
+--     state <- mGet
-    let key = ExactPrint.mkAnnKey ast
+--     let key = ExactPrint.mkAnnKey ast
-    let anns = _lstate_comments state
+--     let anns = _lstate_comments state
-    let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns
+--     let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns
-    mSet $ state
+--     mSet $ state
-      { _lstate_comments = Map.adjust
+--       { _lstate_comments = Map.adjust
-        (\ann -> ann { ExactPrint.annPriorComments = [] })
+--         (\ann -> ann { ExactPrint.annPriorComments = [] })
-        key
+--         key
-        anns
+--         anns
-      }
+--       }
-    return mAnn
+--     return mAnn
-  case mAnn of
+--   case mAnn of
-    Nothing -> return ()
+--     Nothing -> return ()
-    Just priors -> do
+--     Just priors -> do
-      unless (null priors) $ layoutSetCommentCol
+--       unless (null priors) $ layoutSetCommentCol
-      priors `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->
+--       priors `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->
-        do
+--         do
-          replicateM_ x layoutWriteNewline
+--           replicateM_ x layoutWriteNewline
-          layoutWriteAppendSpaces y
+--           layoutWriteAppendSpaces y
-          layoutWriteAppendMultiline $ Text.lines $ Text.pack comment
+--           layoutWriteAppendMultiline $ Text.lines $ Text.pack comment
 
 -- TODO: update and use, or clean up. Currently dead code.
 -- this currently only extracs from the `annsDP` field of Annotations.
 -- per documentation, this seems sufficient, as the
 -- "..`annFollowingComments` are only added by AST transformations ..".
-layoutWritePostComments
+-- layoutWritePostComments
-  :: ( Data.Data.Data ast
+--   :: ( Data.Data.Data ast
-     , MonadMultiWriter Text.Builder.Builder m
+--      , MonadMultiWriter Text.Builder.Builder m
-     , MonadMultiState LayoutState m
+--      , MonadMultiState LayoutState m
-     )
+--      )
-  => Located ast
+--   => Located ast
-  -> m ()
+--   -> m ()
-layoutWritePostComments ast = do
+-- layoutWritePostComments ast = do
-  mAnn <- do
+--   mAnn <- do
-    state <- mGet
+--     state <- mGet
-    let key = ExactPrint.mkAnnKey ast
+--     let key = ExactPrint.mkAnnKey ast
-    let anns = _lstate_comments state
+--     let anns = _lstate_comments state
-    let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns
+--     let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns
-    mSet $ state
+--     mSet $ state
-      { _lstate_comments = Map.adjust
+--       { _lstate_comments = Map.adjust
-        (\ann -> ann { ExactPrint.annFollowingComments = [] })
+--         (\ann -> ann { ExactPrint.annFollowingComments = [] })
-        key
+--         key
-        anns
+--         anns
-      }
+--       }
-    return mAnn
+--     return mAnn
-  case mAnn of
+--   case mAnn of
-    Nothing -> return ()
+--     Nothing -> return ()
-    Just posts -> do
+--     Just posts -> do
-      unless (null posts) $ layoutSetCommentCol
+--       unless (null posts) $ layoutSetCommentCol
-      posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->
+--       posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->
-        do
+--         do
-          replicateM_ x layoutWriteNewline
+--           replicateM_ x layoutWriteNewline
-          layoutWriteAppend $ Text.pack $ replicate y ' '
+--           layoutWriteAppend $ Text.pack $ replicate y ' '
-          mModify $ \s -> s { _lstate_addSepSpace = Nothing }
+--           mModify $ \s -> s { _lstate_addSepSpace = Nothing }
-          layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment
+--           layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment
 
 layoutIndentRestorePostComment
   :: (MonadMultiState LayoutState m, MonadMultiWriter Text.Builder.Builder m)

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

@@ -0,0 +1,94 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE ConstraintKinds #-}
+
+module Language.Haskell.Brittany.Internal.WriteBriDoc.Types where
+
+import           Language.Haskell.Brittany.Internal.Prelude
+
+import qualified Safe
+import           GHC                            ( LEpaComment
+                                                )
+import qualified Data.Text.Lazy.Builder        as TextL.Builder
+
+import           Language.Haskell.Brittany.Internal.Config.Types
+import           Language.Haskell.Brittany.Internal.Types
+
+
+
+data LayoutState = LayoutState
+  { _lstate_baseYs           :: [Int]
+     -- ^ stack of number of current indentation columns
+     -- (not number of indentations).
+  , _lstate_curYOrAddNewline :: Either Int Int
+             -- ^ Either:
+             -- 1) number of chars in the current line.
+             -- 2) number of newlines to be inserted before inserting any
+             --    non-space elements.
+  , _lstate_indLevels        :: [Int]
+    -- ^ stack of current indentation levels. set for
+    -- any layout-affected elements such as
+    -- let/do/case/where elements.
+    -- The main purpose of this member is to
+    -- properly align comments, as their
+    -- annotation positions are relative to the
+    -- current layout indentation level.
+  , _lstate_indLevelLinger   :: Int -- like a "last" of indLevel. Used for
+                                  -- properly treating cases where comments
+                                  -- on the first indented element have an
+                                  -- annotation offset relative to the last
+                                  -- non-indented element, which is confusing.
+  -- , _lstate_comments      :: Anns
+  , _lstate_commentCol       :: Maybe Int -- this communicates two things:
+                                       -- firstly, that cursor is currently
+                                       -- at the end of a comment (so needs
+                                       -- newline before any actual content).
+                                       -- secondly, the column at which
+                                       -- insertion of comments started.
+  , _lstate_addSepSpace      :: Maybe Int -- number of spaces to insert if anyone
+                                       -- writes (any non-spaces) in the
+                                       -- current line.
+  -- , _lstate_isNewline     :: NewLineState
+  --     -- captures if the layouter currently is in a new line, i.e. if the
+  --     -- current line only contains (indentation) spaces.
+  -- this is mostly superseeded by curYOrAddNewline, iirc.
+  , _lstate_commentNewlines  :: Int -- number of newlines inserted due to
+                                   -- move-to-DP at a start of a comment.
+                                   -- Necessary because some keyword DPs
+                                   -- are relative to the last non-comment
+                                   -- entity (for some reason).
+                                   -- This is not very strictly reset to 0,
+                                   -- so we might in some cases get "artifacts"
+                                   -- from previous document elements.
+                                   -- But the worst effect at the moment would
+                                   -- be that we introduce less newlines on
+                                   -- moveToKWDP, which seems harmless enough.
+  }
+
+lstate_baseY :: LayoutState -> Int
+lstate_baseY = Safe.headNote "lstate_baseY" . _lstate_baseYs
+
+lstate_indLevel :: LayoutState -> Int
+lstate_indLevel = Safe.headNote "lstate_indLevel" . _lstate_indLevels
+
+-- evil, incomplete Show instance; only for debugging.
+instance Show LayoutState where
+  show state =
+    "LayoutState"
+    ++ "{baseYs=" ++ show (_lstate_baseYs state)
+    ++ ",curYOrAddNewline=" ++ show (_lstate_curYOrAddNewline state)
+    ++ ",indLevels=" ++ show (_lstate_indLevels state)
+    ++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state)
+    ++ ",commentCol=" ++ show (_lstate_commentCol state)
+    ++ ",addSepSpace=" ++ show (_lstate_addSepSpace state)
+    ++ ",commentNewlines=" ++ show (_lstate_commentNewlines state)
+    ++ "}"
+
+
+type LayoutConstraints m
+  = ( MonadMultiReader Config m
+    , MonadMultiWriter TextL.Builder.Builder m
+    , MonadMultiWriter (Seq String) m
+    , MonadMultiState LayoutState m
+    , MonadMultiState CommentCounter m
+    , MonadMultiState [GHC.LEpaComment] m
+    )

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

@@ -10,22 +10,21 @@ import Data.CZipWith
 import qualified Data.Either
 import qualified Data.List.Extra
 import qualified Data.Monoid
-import qualified Data.Semigroup as Semigroup
 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
+import Language.Haskell.Brittany.Internal.Config.Config
 import Language.Haskell.Brittany.Internal.Config.Types
-import Language.Haskell.Brittany.Internal.Obfuscation
+import Language.Haskell.Brittany.Internal.Components.Obfuscation
 import Language.Haskell.Brittany.Internal.Prelude
-import Language.Haskell.Brittany.Internal.PreludeUtils
 import Language.Haskell.Brittany.Internal.Types
 import Language.Haskell.Brittany.Internal.Utils
 import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
@@ -60,6 +59,51 @@ main = do
   args <- Environment.getArgs
   mainWith progName args
 
+testMain :: IO ()
+testMain = do
+  h <- System.IO.openFile "local/sample-folder/err.txt" System.IO.WriteMode
+  let cmdlineR =
+        runCmdParser
+            Nothing
+            (InputArgs
+              [ "--output-on-errors"
+              , "--dump-ast-full"
+              , "--omit-output-check"
+              -- , "--dump-bridoc-alt"
+              , "--dump-bridoc-floating"
+              -- , "--dump-bridoc-par"
+              -- , "--dump-bridoc-columns"
+              , "--dump-bridoc-final"
+              ]
+            )
+          $ do
+              reorderStart
+              c <- cmdlineConfigParser
+              reorderStop
+              addCmdImpl c
+  let cmdlineConfig = case _ppi_value cmdlineR of
+        Left  err       -> error (show err)
+        Right (Nothing) -> error "could not parse config"
+        Right (Just r ) -> r
+  configsToLoad <-
+    maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath)
+  config <- runMaybeT (readConfigs cmdlineConfig configsToLoad)
+        -- (readConfigsWithUserConfig cmdlineConfig configsToLoad)
+                                                                >>= \case
+    Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53)
+    Just x  -> return x
+  System.IO.hPutStrLn h $ showConfigYaml config
+  e <- coreIO (System.IO.hPutStrLn h)
+              config
+              False
+              False
+              (Just "local/sample-folder/Test.hs")
+              (Just "local/sample-folder/out.txt")
+  case e of
+    Left  i         -> print i
+    Right Changes   -> putStrLn "Changes"
+    Right NoChanges -> putStrLn "NoChanges"
+
 mainWith :: String -> [String] -> IO ()
 mainWith progName args =
   Environment.withProgName progName
@@ -246,7 +290,6 @@ mainCmdParser = do
         [Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x)
         _ -> System.Exit.exitWith (System.Exit.ExitFailure 1)
 
-
 data ChangeStatus = Changes | NoChanges
   deriving (Eq)
 
@@ -337,11 +380,11 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
         putErrorLn "parse error:"
         putErrorLn left
         ExceptT.throwE 60
-      Right (anns, parsedSource, hasCPP) -> do
+      Right (parsedSource, hasCPP) -> do
-        (inlineConf, perItemConf) <-
+        (inlineConf, perItemConf) <- do
-          case
+          resE <-
-            extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource)
+            liftIO $ ExceptT.runExceptT $ extractCommentConfigs putErrorLnIO parsedSource
-          of
+          case resE of
             Left (err, input) -> do
               putErrorLn $ "Error: parse error in inline configuration:"
               putErrorLn err
@@ -351,8 +394,8 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
               pure c
         let moduleConf = cZipWith fromOptionIdentity config inlineConf
         when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do
-          let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource
+          let val = printTreeWithCustom 160 customLayouterF parsedSource
-          trace ("---- ast ----\n" ++ show val) $ return ()
+          putErrorLn ("---- ast ----\n" ++ show val)
         let
           disableFormatting =
             moduleConf & _conf_disable_formatting & confUnpack
@@ -361,7 +404,7 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
             | disableFormatting -> do
               pure ([], originalContents, False)
             | exactprintOnly -> do
-              let r = Text.pack $ ExactPrint.exactPrint parsedSource anns
+              let r = Text.pack $ ExactPrint.exactPrint parsedSource
               pure ([], r, r /= originalContents)
             | otherwise -> do
               let
@@ -371,13 +414,9 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
                     .> _econf_omit_output_valid_check
                     .> confUnpack
               (ews, outRaw) <- if hasCPP || omitCheck
-                then return
+                then liftIO $ processModule (TraceFunc putErrorLnIO) moduleConf perItemConf parsedSource
-                  $ pPrintModule moduleConf perItemConf anns parsedSource
+                else liftIO
-                else liftIO $ pPrintModuleAndCheck
+                  $ pPrintModuleAndCheck (TraceFunc putErrorLnIO) moduleConf perItemConf parsedSource
-                  moduleConf
-                  perItemConf
-                  anns
-                  parsedSource
               let
                 hackF s = fromMaybe s $ TextL.stripPrefix
                   (TextL.pack "-- BRITANY_INCLUDE_HACK ")
@@ -398,6 +437,7 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
           customErrOrder LayoutWarning{} = -1 :: Int
           customErrOrder ErrorOutputCheck{} = 1
           customErrOrder ErrorUnusedComment{} = 2
+          customErrOrder ErrorUnusedComments{} = 3
           customErrOrder ErrorUnknownNode{} = -2 :: Int
           customErrOrder ErrorMacroConfig{} = 5
         unless (null errsWarns) $ do
@@ -445,6 +485,17 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
               unused `forM_` \case
                 ErrorUnusedComment str -> putErrorLn str
                 _ -> error "cannot happen (TM)"
+            unused@(ErrorUnusedComments{} : _) -> do
+              unused `forM_` \case
+                ErrorUnusedComments (L (GHC.SrcSpanAnn _ ann) _) cIn cOut -> do
+                  putErrorLn
+                    $ "Error: detected unprocessed comments ("
+                    ++ show cOut ++ " out of " ++ show cIn ++ ")."
+                    ++ " The transformation output will most likely"
+                    ++ " not contain some of the comments"
+                    ++ " present in the input haskell source file."
+                  putErrorLn $ "Affected is the declaration at " ++ show (astToDoc ann)
+                _ -> error "cannot happen (TM)"
             (ErrorMacroConfig err input : _) -> do
               putErrorLn $ "Error: parse error in inline configuration:"
               putErrorLn err
@@ -473,10 +524,10 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
               Nothing -> liftIO $ Text.IO.putStr $ outSText
               Just p -> liftIO $ do
                 let
-                  isIdentical = case inputPathM of
+                  shouldWrite = case inputPathM of
-                    Nothing -> False
+                    Nothing -> True
-                    Just _ -> not hasChanges
+                    Just p2 -> hasChanges || p /= p2
-                unless isIdentical $ Text.IO.writeFile p $ outSText
+                when shouldWrite $ Text.IO.writeFile p $ outSText
 
         when (checkMode && hasChanges) $ case inputPathM of
           Nothing -> pure ()

source/test-suite/Main.hs

@@ -12,10 +12,9 @@ import qualified GHC.OldList as List
 import qualified Data.Map.Strict as Map
 import Data.These
 import Language.Haskell.Brittany.Internal
-import Language.Haskell.Brittany.Internal.Config
+import Language.Haskell.Brittany.Internal.Config.Config
 import Language.Haskell.Brittany.Internal.Config.Types
 import Language.Haskell.Brittany.Internal.Prelude
-import Language.Haskell.Brittany.Internal.PreludeUtils
 import qualified System.Directory
 import System.FilePath ((</>))
 import System.Timeout (timeout)