Refactor file/module structure again again

brittany.cabal

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@@ -21,7 +21,7 @@ import GHC.Types.SrcLoc (Located, getLoc, unLoc)
 import qualified GHC
 import qualified GHC.Types.SrcLoc as GHC
 import Language.Haskell.Brittany.Internal.Config.Types
-import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
+import Language.Haskell.Brittany.Internal.ToBriDocTools
 import Language.Haskell.Brittany.Internal.Prelude
 import Language.Haskell.Brittany.Internal.Types
 import qualified Language.Haskell.GHC.ExactPrint as ExactPrint

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

@@ -23,7 +23,7 @@ import qualified GHC.Types.SrcLoc              as GHC
 import           Language.Haskell.Brittany.Internal.Components.BriDoc
 import           Language.Haskell.Brittany.Internal.Config.Types
 import           Language.Haskell.Brittany.Internal.Prelude
-import           Language.Haskell.Brittany.Internal.S3_ToBriDocTools
+import           Language.Haskell.Brittany.Internal.ToBriDocTools
 import           Language.Haskell.Brittany.Internal.Types
 import           Language.Haskell.Brittany.Internal.Utils
 

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

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

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

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

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

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

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

@@ -12,7 +12,7 @@ import           Language.Haskell.Brittany.Internal.Components.BriDoc
 import           Language.Haskell.Brittany.Internal.Components.OpTree
 import           Language.Haskell.Brittany.Internal.Config.Types
 import           Language.Haskell.Brittany.Internal.Prelude
-import           Language.Haskell.Brittany.Internal.S3_ToBriDocTools
+import           Language.Haskell.Brittany.Internal.ToBriDocTools
 import           Language.Haskell.Brittany.Internal.Types
 import           Language.Haskell.Brittany.Internal.Utils
 

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

@@ -10,7 +10,7 @@ import GHC (GenLocated(L), ol_val)
 import GHC.Hs
 import qualified GHC.OldList as List
 import GHC.Types.Basic
-import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
+import Language.Haskell.Brittany.Internal.ToBriDocTools
 import Language.Haskell.Brittany.Internal.Prelude
 import Language.Haskell.Brittany.Internal.Types
 import Language.Haskell.Brittany.Internal.Components.BriDoc

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

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

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

@@ -14,7 +14,7 @@ import GHC.Utils.Outputable (ftext, showSDocUnsafe)
 import           GHC.Types.Fixity               ( Fixity(Fixity)
                                                 , FixityDirection(InfixN)
                                                 )
-import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
+import Language.Haskell.Brittany.Internal.ToBriDocTools
 import Language.Haskell.Brittany.Internal.Prelude
 import Language.Haskell.Brittany.Internal.Types
 import Language.Haskell.Brittany.Internal.Components.BriDoc

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

@@ -1,7 +1,7 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
-module Language.Haskell.Brittany.Internal.S3_ToBriDocTools where
+module Language.Haskell.Brittany.Internal.ToBriDocTools where
 
 import qualified Control.Monad.Writer.Strict   as Writer
 import qualified Data.Char                     as Char

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

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

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

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

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

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