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

Refactor/Auto-format Main, Brittany.Internal

pull/153/head
Lennart Spitzner 2018-06-04 17:06:23 +02:00
parent 57c48f64c1
commit 6725d0e119
2 changed files with 324 additions and 238 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

161
src-brittany/Main.hs
View File

@ -6,8 +6,10 @@ module Main where
#include "prelude.inc"
-- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 }
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate
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.Parsers as ExactPrint.Parsers
import qualified Data.Map as Map
@ -45,6 +47,7 @@ import qualified GHC.LanguageExtensions.Type as GHC
import Paths_brittany
data WriteMode = Display | Inplace
instance Read WriteMode where
@ -93,9 +96,14 @@ helpDoc = PP.vcat $ List.intersperse
, "codebase without having backups."
]
, parDoc $ "There is NO WARRANTY, to the extent permitted by law."
, parDocW ["This program is free software released under the AGPLv3.", "For details use the --license flag."]
, parDocW
[ "This program is free software released under the AGPLv3."
, "For details use the --license flag."
]
, parDoc $ "See https://github.com/lspitzner/brittany"
, parDoc $ "Please report bugs at" ++ " https://github.com/lspitzner/brittany/issues"
, parDoc
$ "Please report bugs at"
++ " https://github.com/lspitzner/brittany/issues"
]
licenseDoc :: PP.Doc
@ -133,13 +141,21 @@ mainCmdParser helpDesc = do
printHelp <- addSimpleBoolFlag "h" ["help"] mempty
printVersion <- addSimpleBoolFlag "" ["version"] mempty
printLicense <- addSimpleBoolFlag "" ["license"] mempty
configPaths <- addFlagStringParams "" ["config-file"] "PATH" (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ?
configPaths <- addFlagStringParams ""
["config-file"]
"PATH"
(flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ?
cmdlineConfig <- cmdlineConfigParser
suppressOutput <- addSimpleBoolFlag
""
["suppress-output"]
(flagHelp $ parDoc "suppress the regular output, i.e. the transformed haskell source")
_verbosity <- addSimpleCountFlag "v" ["verbose"] (flagHelp $ parDoc "[currently without effect; TODO]")
(flagHelp $ parDoc
"suppress the regular output, i.e. the transformed haskell source"
)
_verbosity <- addSimpleCountFlag
"v"
["verbose"]
(flagHelp $ parDoc "[currently without effect; TODO]")
writeMode <- addFlagReadParam
""
["write-mode"]
@ -152,7 +168,9 @@ mainCmdParser helpDesc = do
)
Data.Monoid.<> flagDefault Display
)
inputParams <- addParamNoFlagStrings "PATH" (paramHelpStr "paths to input/inout haskell source files")
inputParams <- addParamNoFlagStrings
"PATH"
(paramHelpStr "paths to input/inout haskell source files")
reorderStop
addCmdImpl $ void $ do
when printLicense $ do
@ -165,25 +183,35 @@ mainCmdParser helpDesc = do
putStrLn $ "There is NO WARRANTY, to the extent permitted by law."
System.Exit.exitSuccess
when printHelp $ do
liftIO $ putStrLn $ PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } $ ppHelpShallow helpDesc
liftIO
$ putStrLn
$ PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 }
$ ppHelpShallow helpDesc
System.Exit.exitSuccess
let inputPaths = if null inputParams then [Nothing] else map Just inputParams
let inputPaths =
if null inputParams then [Nothing] else map Just inputParams
let outputPaths = case writeMode of
Display -> repeat Nothing
Inplace -> inputPaths
configsToLoad <- liftIO $ if null configPaths
then maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath)
then
maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath)
else pure configPaths
config <- runMaybeT (readConfigsWithUserConfig cmdlineConfig configsToLoad) >>= \case
config <-
runMaybeT (readConfigsWithUserConfig cmdlineConfig configsToLoad)
>>= \case
Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53)
Just x -> return x
when (config & _conf_debug & _dconf_dump_config & confUnpack) $
trace (showConfigYaml config) $ return ()
when (config & _conf_debug & _dconf_dump_config & confUnpack)
$ trace (showConfigYaml config)
$ return ()
results <- zipWithM (coreIO putStrErrLn config suppressOutput) inputPaths outputPaths
results <- zipWithM (coreIO putStrErrLn config suppressOutput)
inputPaths
outputPaths
case results of
xs | all Data.Either.isRight xs -> pure ()
[Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x)
@ -202,7 +230,8 @@ coreIO
-> Maybe FilePath.FilePath -- ^ input filepath; stdin if Nothing.
-> Maybe FilePath.FilePath -- ^ output filepath; stdout if Nothing.
-> IO (Either Int ()) -- ^ Either an errorNo, or success.
coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runExceptT $ do
coreIO putErrorLnIO config suppressOutput 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
@ -217,10 +246,16 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx
-- 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 = (config & _conf_roundtrip_exactprint_only & confUnpack)
|| (config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack)
let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
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
cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
then case cppMode of
CPPModeAbort -> do
return $ Left "Encountered -XCPP. Aborting."
@ -236,11 +271,17 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx
parseResult <- 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
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.hGetContents System.IO.stdin
liftIO $ parseModuleFromString ghcOptions "stdin" cppCheckFunc (hackTransform inputString)
liftIO $ parseModuleFromString ghcOptions
"stdin"
cppCheckFunc
(hackTransform inputString)
Just p -> liftIO $ parseModule ghcOptions p cppCheckFunc
case parseResult of
Left left -> do
@ -248,17 +289,19 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx
putErrorLn $ show left
ExceptT.throwE 60
Right (anns, parsedSource, hasCPP) -> do
(inlineConf, perItemConf) <- case extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) of
(inlineConf, perItemConf) <-
case
extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource)
of
Left (err, input) -> do
putErrorLn
$ "Error: parse error in inline configuration:"
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
trace ("---- ast ----\n" ++ show val) $ return ()
(errsWarns, outSText) <- do
@ -266,13 +309,27 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx
then do
pure ([], Text.pack $ ExactPrint.exactPrint parsedSource anns)
else do
let omitCheck = moduleConf & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack
let omitCheck =
moduleConf
& _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 anns parsedSource
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") $ fmap hackF $ TextL.splitOn (TextL.pack "\n") outRaw
then return
$ pPrintModule moduleConf perItemConf anns parsedSource
else liftIO $ pPrintModuleAndCheck moduleConf
perItemConf
anns
parsedSource
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")
$ fmap hackF
$ TextL.splitOn (TextL.pack "\n") outRaw
else outRaw
out' <- if moduleConf & _conf_obfuscate & confUnpack
then lift $ obfuscate out
@ -285,10 +342,15 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx
customErrOrder ErrorUnknownNode{} = 3
customErrOrder ErrorMacroConfig{} = 5
when (not $ null errsWarns) $ do
let groupedErrsWarns = Data.List.Extra.groupOn customErrOrder $ List.sortOn customErrOrder $ errsWarns
let groupedErrsWarns =
Data.List.Extra.groupOn customErrOrder
$ List.sortOn customErrOrder
$ errsWarns
groupedErrsWarns `forM_` \case
(ErrorOutputCheck{} : _) -> do
putErrorLn $ "ERROR: brittany pretty printer" ++ " returned syntactically invalid result."
putErrorLn
$ "ERROR: brittany pretty printer"
++ " returned syntactically invalid result."
(ErrorInput str : _) -> do
putErrorLn $ "ERROR: parse error: " ++ str
uns@(ErrorUnknownNode{} : _) -> do
@ -296,7 +358,13 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx
uns `forM_` \case
ErrorUnknownNode str ast -> do
putErrorLn str
when (config & _conf_debug & _dconf_dump_ast_unknown & confUnpack) $ do
when
( config
& _conf_debug
& _dconf_dump_ast_unknown
& confUnpack
)
$ do
putErrorLn $ " " ++ show (astToDoc ast)
_ -> error "cannot happen (TM)"
warns@(LayoutWarning{} : _) -> do
@ -315,20 +383,27 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx
ErrorUnusedComment str -> putErrorLn str
_ -> error "cannot happen (TM)"
(ErrorMacroConfig err input : _) -> do
putErrorLn
$ "Error: parse error in inline configuration:"
putErrorLn $ "Error: parse error in inline configuration:"
putErrorLn err
putErrorLn $ " in the string \"" ++ input ++ "\"."
[] -> error "cannot happen"
-- TODO: don't output anything when there are errors unless user
-- adds some override?
let hasErrors = case config & _conf_errorHandling & _econf_Werror & confUnpack of
let
hasErrors =
case config & _conf_errorHandling & _econf_Werror & confUnpack of
False -> 0 < maximum (-1 : fmap customErrOrder errsWarns)
True -> not $ null errsWarns
outputOnErrs = config & _conf_errorHandling & _econf_produceOutputOnErrors & confUnpack
outputOnErrs =
config
& _conf_errorHandling
& _econf_produceOutputOnErrors
& confUnpack
shouldOutput = not suppressOutput && (not hasErrors || outputOnErrs)
when shouldOutput $ addTraceSep (_conf_debug config) $ case outputPathM of
when shouldOutput
$ addTraceSep (_conf_debug config)
$ case outputPathM of
Nothing -> liftIO $ Text.IO.putStr $ outSText
Just p -> liftIO $ do
isIdentical <- case inputPathM of
@ -340,8 +415,8 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx
-- 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.)
-- (not identical -> read is not finished ->
-- handle still open -> write below crashes - evil.)
unless isIdentical $ Text.IO.writeFile p $ outSText
when hasErrors $ ExceptT.throwE 70

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

@ -17,6 +17,7 @@ where
#include "prelude.inc"
-- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 }
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers
@ -50,9 +51,13 @@ import Language.Haskell.Brittany.Internal.Transformations.Par
import Language.Haskell.Brittany.Internal.Transformations.Columns
import Language.Haskell.Brittany.Internal.Transformations.Indent
import qualified GHC as GHC hiding (parseModule)
import qualified GHC as GHC
hiding ( parseModule )
import ApiAnnotation ( AnnKeywordId(..) )
import GHC ( runGhc, GenLocated(L), moduleNameString )
import GHC ( runGhc
, GenLocated(L)
, moduleNameString
)
import SrcLoc ( SrcSpan )
import HsSyn
import qualified DynFlags as GHC
@ -267,7 +272,8 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do
& confUnpack
(ews, outRaw) <- if hasCPP || omitCheck
then return $ pPrintModule moduleConfig perItemConf anns parsedSource
else lift $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource
else lift
$ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource
let hackF s = fromMaybe s
$ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
pure $ if hackAroundIncludes
@ -303,8 +309,7 @@ pPrintModule
-> GHC.ParsedSource
-> ([BrittanyError], TextL.Text)
pPrintModule conf inlineConf anns parsedModule =
let
((out, errs), debugStrings) =
let ((out, errs), debugStrings) =
runIdentity
$ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiWriterAW
@ -318,15 +323,12 @@ pPrintModule conf inlineConf anns parsedModule =
traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations
$ annsDoc anns
ppModule parsedModule
tracer =
if Seq.null debugStrings
then
id
tracer = if Seq.null debugStrings
then id
else
trace ("---- DEBUGMESSAGES ---- ")
. foldr (seq . join trace) id debugStrings
in
tracer $ (errs, Text.Builder.toLazyText out)
in tracer $ (errs, Text.Builder.toLazyText out)
-- unless () $ do
--
-- debugStrings `forM_` \s ->
@ -374,8 +376,8 @@ parsePrintModuleTests conf filename input = do
.> confUnpack
(errs, ltext) <- if omitCheck
then return $ pPrintModule moduleConf perItemConf anns parsedModule
else
lift $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule
else lift
$ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule
if null errs
then pure $ TextL.toStrict $ ltext
else
@ -426,7 +428,8 @@ parsePrintModuleTests conf filename input = do
toLocal :: Config -> ExactPrint.Anns -> PPMLocal a -> PPM a
toLocal conf anns m = do
(x, write) <- lift $ MultiRWSS.runMultiRWSTAW (conf :+: anns :+: HNil) HNil $ m
(x, write) <-
lift $ MultiRWSS.runMultiRWSTAW (conf :+: anns :+: HNil) HNil $ m
MultiRWSS.mGetRawW >>= \w -> MultiRWSS.mPutRawW (w `mappend` write)
pure x
@ -449,8 +452,8 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do
config <- mAsk
let config' = cZipWith fromOptionIdentity config $ mconcat
(catMaybes (mBindingConfs ++ [mDeclConf]))
let config' = cZipWith fromOptionIdentity config
$ mconcat (catMaybes (mBindingConfs ++ [mDeclConf]))
let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack
toLocal config' filteredAnns $ do
@ -491,7 +494,8 @@ getDeclBindingNames (L _ decl) = case decl of
-- Prints the information associated with the module annotation
-- This includes the imports
ppPreamble :: GenLocated SrcSpan (HsModule GhcPs)
ppPreamble
:: GenLocated SrcSpan (HsModule GhcPs)
-> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)]
ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do
filteredAnns <- mAsk <&> \annMap ->
@ -583,26 +587,33 @@ layoutBriDoc briDoc = do
$ briDoc
-- bridoc transformation: remove alts
transformAlts briDoc >>= mSet
mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-alt"
_dconf_dump_bridoc_simpl_alt
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"
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
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
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
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