Refactor internals and expose pPrintModule

src-brittany/Main.hs

@@ -328,18 +328,6 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM =
         putErrorLn $ show left
         ExceptT.throwE 60
       Right (anns, parsedSource, hasCPP) -> do
-        (inlineConf, perItemConf) <-
-          case
-            extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource)
-          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 100 (customLayouterF anns) parsedSource
           trace ("---- ast ----\n" ++ show val) $ return ()
@@ -349,15 +337,14 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM =
               pure ([], Text.pack $ ExactPrint.exactPrint parsedSource anns)
             else do
               let omitCheck =
-                    moduleConf
+                    config
                       &  _conf_errorHandling
                       .> _econf_omit_output_valid_check
                       .> confUnpack
               (ews, outRaw) <- if hasCPP || omitCheck
                 then return
-                  $ pPrintModule moduleConf perItemConf anns parsedSource
+                  $ pPrintModule config anns parsedSource
-                else liftIO $ pPrintModuleAndCheck moduleConf
+                else liftIO $ pPrintModuleAndCheck config
-                                                   perItemConf
                                                    anns
                                                    parsedSource
               let hackF s = fromMaybe s $ TextL.stripPrefix
@@ -369,7 +356,7 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM =
                       $ fmap hackF
                       $ TextL.splitOn (TextL.pack "\n") outRaw
                     else outRaw
-              out' <- if moduleConf & _conf_obfuscate & confUnpack
+              out' <- if config & _conf_obfuscate & confUnpack
                 then lift $ obfuscate out
                 else pure out
               pure $ (ews, out')

src/Language/Haskell/Brittany.hs

@@ -2,6 +2,7 @@
 
 module Language.Haskell.Brittany
   ( parsePrintModule
+  , pPrintModule
   , staticDefaultConfig
   , forwardOptionsSyntaxExtsEnabled
   , userConfigPath

src/Language/Haskell/Brittany/Internal.hs

@@ -263,20 +263,16 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do
     case parseResult of
       Left  err -> throwE [ErrorInput err]
       Right x   -> pure x
-  (inlineConf, perItemConf) <-
-    either (throwE . (: []) . uncurry ErrorMacroConfig) pure
-      $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource)
-  let moduleConfig = cZipWith fromOptionIdentity config inlineConf
   (errsWarns, outputTextL) <- do
     let omitCheck =
-          moduleConfig
+          config
             & _conf_errorHandling
             & _econf_omit_output_valid_check
             & confUnpack
     (ews, outRaw) <- if hasCPP || omitCheck
-      then return $ pPrintModule moduleConfig perItemConf anns parsedSource
+      then return $ pPrintModule config anns parsedSource
       else lift
-        $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource
+        $ pPrintModuleAndCheck config anns parsedSource
     let hackF s = fromMaybe s
           $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
     pure $ if hackAroundIncludes
@@ -294,7 +290,7 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do
       customErrOrder ErrorUnknownNode{}   = 3
       customErrOrder ErrorMacroConfig{}   = 5
   let hasErrors =
-        case moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack of
+        case config & _conf_errorHandling & _econf_Werror & confUnpack of
           False -> 0 < maximum (-1 : fmap customErrOrder errsWarns)
           True  -> not $ null errsWarns
   if hasErrors then throwE $ errsWarns else pure $ TextL.toStrict outputTextL
@@ -307,31 +303,37 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do
 -- can occur.
 pPrintModule
   :: Config
-  -> PerItemConfig
   -> ExactPrint.Anns
   -> GHC.ParsedSource
   -> ([BrittanyError], TextL.Text)
-pPrintModule conf inlineConf anns parsedModule =
+pPrintModule conf anns parsedModule =
-  let ((out, errs), debugStrings) =
+  case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of
-        runIdentity
+    Left (eErr, eInp) -> ([ErrorMacroConfig eErr eInp], TextL.empty)
-          $ MultiRWSS.runMultiRWSTNil
+    Right (inlineConf, perItemConf) ->
-          $ MultiRWSS.withMultiWriterAW
+      let moduleConfig = cZipWith fromOptionIdentity conf inlineConf
-          $ MultiRWSS.withMultiWriterAW
+          ((out, errs), debugStrings) =
-          $ MultiRWSS.withMultiWriterW
+            runIdentity
-          $ MultiRWSS.withMultiReader anns
+              $ MultiRWSS.runMultiRWSTNil
-          $ MultiRWSS.withMultiReader conf
+              $ MultiRWSS.withMultiWriterAW
-          $ MultiRWSS.withMultiReader inlineConf
+              $ MultiRWSS.withMultiWriterAW
-          $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns)
+              $ MultiRWSS.withMultiWriterW
-          $ do
+              $ MultiRWSS.withMultiReader anns
-              traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations
+              $ MultiRWSS.withMultiReader moduleConfig
-                $ annsDoc anns
+              $ MultiRWSS.withMultiReader perItemConf
-              ppModule parsedModule
+              $ MultiRWSS.withMultiReader
-      tracer = if Seq.null debugStrings
+                  (extractToplevelAnns parsedModule anns)
-        then id
+              $ do
-        else
+                  traceIfDumpConf "bridoc annotations raw"
-          trace ("---- DEBUGMESSAGES ---- ")
+                                  _dconf_dump_annotations
-            . foldr (seq . join trace) id debugStrings
+                    $ annsDoc anns
-  in  tracer $ (errs, Text.Builder.toLazyText out)
+                  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 ->
@@ -341,13 +343,12 @@ pPrintModule conf inlineConf anns parsedModule =
 -- if it does not.
 pPrintModuleAndCheck
   :: Config
-  -> PerItemConfig
   -> ExactPrint.Anns
   -> GHC.ParsedSource
   -> IO ([BrittanyError], TextL.Text)
-pPrintModuleAndCheck conf inlineConf anns parsedModule = do
+pPrintModuleAndCheck conf anns parsedModule = do
+  let (errs, output) = pPrintModule conf anns parsedModule
   let ghcOptions     = conf & _conf_forward & _options_ghc & runIdentity
-  let (errs, output) = pPrintModule conf inlineConf anns parsedModule
   parseResult <- parseModuleFromString ghcOptions
                                        "output"
                                        (\_ -> return $ Right ())
@@ -367,20 +368,15 @@ parsePrintModuleTests conf filename input = do
   case parseResult of
     Left  (_   , s           ) -> return $ Left $ "parsing error: " ++ s
     Right (anns, parsedModule) -> runExceptT $ do
-      (inlineConf, perItemConf) <-
-        case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of
-          Left  err -> throwE $ "error in inline config: " ++ show err
-          Right x   -> pure x
-      let moduleConf = cZipWith fromOptionIdentity conf inlineConf
       let omitCheck =
             conf
               &  _conf_errorHandling
               .> _econf_omit_output_valid_check
               .> confUnpack
       (errs, ltext) <- if omitCheck
-        then return $ pPrintModule moduleConf perItemConf anns parsedModule
+        then return $ pPrintModule conf anns parsedModule
         else lift
-          $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule
+          $ pPrintModuleAndCheck conf anns parsedModule
       if null errs
         then pure $ TextL.toStrict $ ltext
         else