hexagoxel
/
brittany
1
0
Fork 0
Code Issues 117 Pull Requests 5 Packages Projects Releases 5 Wiki Activity

Refactor internals and expose pPrintModule

api
Lennart Spitzner 2020-01-09 19:35:20 +01:00
parent af227a797d
commit 8bd669f145
3 changed files with 41 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
src-brittany/Main.hs
View File

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

1
src/Language/Haskell/Brittany.hs
View File

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

76
src/Language/Haskell/Brittany/Internal.hs
View File

@ -263,20 +263,16 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do
case parseResult of 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
$ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource)
let moduleConfig = cZipWith fromOptionIdentity config inlineConf
(errsWarns, outputTextL) <- do (errsWarns, outputTextL) <- do
let omitCheck = let omitCheck =
moduleConfig config
& _conf_errorHandling & _conf_errorHandling
& _econf_omit_output_valid_check & _econf_omit_output_valid_check
& confUnpack & confUnpack
(ews, outRaw) <- if hasCPP || omitCheck (ews, outRaw) <- if hasCPP || omitCheck
then return $ pPrintModule moduleConfig perItemConf anns parsedSource then return $ pPrintModule config anns parsedSource
else lift else lift
$ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource $ pPrintModuleAndCheck config anns parsedSource
let hackF s = fromMaybe s let hackF s = fromMaybe s
$ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
pure $ if hackAroundIncludes pure $ if hackAroundIncludes
@ -294,7 +290,7 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do
customErrOrder ErrorUnknownNode{} = 3 customErrOrder ErrorUnknownNode{} = 3
customErrOrder ErrorMacroConfig{} = 5 customErrOrder ErrorMacroConfig{} = 5
let hasErrors = 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) False -> 0 < maximum (-1 : fmap customErrOrder errsWarns)
True -> not $ null errsWarns True -> not $ null errsWarns
if hasErrors then throwE $ errsWarns else pure $ TextL.toStrict outputTextL if hasErrors then throwE $ errsWarns else pure $ TextL.toStrict outputTextL
@ -307,31 +303,37 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do
-- can occur. -- can occur.
pPrintModule pPrintModule
:: Config :: Config
-> PerItemConfig
-> ExactPrint.Anns -> ExactPrint.Anns
-> GHC.ParsedSource -> GHC.ParsedSource
-> ([BrittanyError], TextL.Text) -> ([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 -- unless () $ do
-- --
-- debugStrings `forM_` \s -> -- debugStrings `forM_` \s ->
@ -341,13 +343,12 @@ pPrintModule conf inlineConf anns parsedModule =
-- if it does not. -- if it does not.
pPrintModuleAndCheck pPrintModuleAndCheck
:: Config :: Config
-> PerItemConfig
-> ExactPrint.Anns -> ExactPrint.Anns
-> GHC.ParsedSource -> GHC.ParsedSource
-> IO ([BrittanyError], TextL.Text) -> 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 ghcOptions = conf & _conf_forward & _options_ghc & runIdentity
let (errs, output) = pPrintModule conf inlineConf anns parsedModule
parseResult <- parseModuleFromString ghcOptions parseResult <- parseModuleFromString ghcOptions
"output" "output"
(\_ -> return $ Right ()) (\_ -> return $ Right ())
@ -367,20 +368,15 @@ parsePrintModuleTests conf filename input = do
case parseResult of case parseResult of
Left (_ , s ) -> return $ Left $ "parsing error: " ++ s Left (_ , s ) -> return $ Left $ "parsing error: " ++ s
Right (anns, parsedModule) -> runExceptT $ do 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 = let omitCheck =
conf conf
& _conf_errorHandling & _conf_errorHandling
.> _econf_omit_output_valid_check .> _econf_omit_output_valid_check
.> confUnpack .> confUnpack
(errs, ltext) <- if omitCheck (errs, ltext) <- if omitCheck
then return $ pPrintModule moduleConf perItemConf anns parsedModule then return $ pPrintModule conf anns parsedModule
else lift else lift
$ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule $ pPrintModuleAndCheck conf anns parsedModule
if null errs if null errs
then pure $ TextL.toStrict $ ltext then pure $ TextL.toStrict $ ltext
else else