diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 527d2e8..7b52a63 100644 --- a/src-brittany/Main.hs +++ b/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 - else liftIO $ pPrintModuleAndCheck moduleConf - perItemConf + $ pPrintModule config anns parsedSource + else liftIO $ pPrintModuleAndCheck config 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') diff --git a/src/Language/Haskell/Brittany.hs b/src/Language/Haskell/Brittany.hs index 9d45dde..1a9b712 100644 --- a/src/Language/Haskell/Brittany.hs +++ b/src/Language/Haskell/Brittany.hs @@ -2,6 +2,7 @@ module Language.Haskell.Brittany ( parsePrintModule + , pPrintModule , staticDefaultConfig , forwardOptionsSyntaxExtsEnabled , userConfigPath diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index e98c0fc..954c6a0 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/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 = - 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) +pPrintModule conf anns parsedModule = + case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of + Left (eErr, eInp) -> ([ErrorMacroConfig eErr eInp], TextL.empty) + Right (inlineConf, perItemConf) -> + let moduleConfig = cZipWith fromOptionIdentity conf inlineConf + ((out, errs), debugStrings) = + runIdentity + $ MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterW + $ MultiRWSS.withMultiReader anns + $ MultiRWSS.withMultiReader moduleConfig + $ MultiRWSS.withMultiReader perItemConf + $ 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 -> @@ -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