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

179
src-brittany/Main.hs
View File

@ -6,19 +6,21 @@ 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
import qualified Data.Monoid
import Text.Read (Read(..))
import Text.Read ( Read(..) )
import qualified Text.ParserCombinators.ReadP as ReadP
import qualified Text.ParserCombinators.ReadPrec as ReadPrec
import qualified Data.Text.Lazy.Builder as Text.Builder
import Control.Monad (zipWithM)
import Control.Monad ( zipWithM )
import Data.CZipWith
import qualified Debug.Trace as Trace
@ -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,26 +141,36 @@ 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"]
"(display|inplace)"
( flagHelp
( PP.vcat
(PP.vcat
[ PP.text "display: output for any input(s) goes to stdout"
, PP.text "inplace: override respective input file (without backup!)"
]
)
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,26 +342,37 @@ 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."
(ErrorInput str:_) -> do
(ErrorOutputCheck{} : _) -> do
putErrorLn
$ "ERROR: brittany pretty printer"
++ " returned syntactically invalid result."
(ErrorInput str : _) -> do
putErrorLn $ "ERROR: parse error: " ++ str
uns@(ErrorUnknownNode{}:_) -> do
uns@(ErrorUnknownNode{} : _) -> do
putErrorLn $ "ERROR: encountered unknown syntactical constructs:"
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
warns@(LayoutWarning{} : _) -> do
putErrorLn $ "WARNINGS:"
warns `forM_` \case
LayoutWarning str -> putErrorLn str
_ -> error "cannot happen (TM)"
unused@(ErrorUnusedComment{}:_) -> do
unused@(ErrorUnusedComment{} : _) -> do
putErrorLn
$ "Error: detected unprocessed comments."
++ " The transformation output will most likely"
@ -314,21 +382,28 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx
unused `forM_` \case
ErrorUnusedComment str -> putErrorLn str
_ -> error "cannot happen (TM)"
(ErrorMacroConfig err input:_) -> do
putErrorLn
$ "Error: parse error in inline configuration:"
(ErrorMacroConfig err input : _) -> do
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

71
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,15 +51,19 @@ 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
import qualified GHC.LanguageExtensions.Type as GHC
import Data.Char (isSpace)
import Data.Char ( isSpace )
@ -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
@ -627,6 +638,6 @@ layoutBriDoc briDoc = do
let remainingComments =
extractAllComments =<< Map.elems (_lstate_comments state')
remainingComments
`forM_` (fst .> show .> ErrorUnusedComment .> (:[]) .> mTell)
`forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell)
return $ ()