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

Auto-reformat Main.hs

pull/35/head
Lennart Spitzner 2017-05-22 15:58:04 +02:00
parent fd9427754e
commit 72c87b7b4e
1 changed files with 60 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
src-brittany/Main.hs
View File

@ -46,20 +46,21 @@ main = mainFromCmdParserWithHelpDesc mainCmdParser
mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) () mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) ()
mainCmdParser helpDesc = do mainCmdParser helpDesc = do
addCmdSynopsis "haskell source pretty printer" addCmdSynopsis "haskell source pretty printer"
addCmdHelp $ PP.vcat $ List.intersperse (PP.text "") addCmdHelp $ PP.vcat $ List.intersperse
[ parDoc $ "Transforms one haskell module by reformatting" (PP.text "")
[ parDoc
$ "Transforms one haskell module by reformatting"
++ " (parts of) the source code (while preserving the" ++ " (parts of) the source code (while preserving the"
++ " parts not transformed)." ++ " parts not transformed)."
, parDoc $ "Based on ghc-exactprint, thus (theoretically) supporting all" , parDoc $ "Based on ghc-exactprint, thus (theoretically) supporting all" ++ " that ghc does."
++ " that ghc does." , parDoc
, parDoc $ "This is an early, experimental release." $ "This is an early, experimental release."
++ " Only type-signatures and function-bindings are transformed." ++ " Only type-signatures and function-bindings are transformed."
++ " There is a check in place, but no warranties that the output" ++ " There is a check in place, but no warranties that the output"
++ " is valid haskell." ++ " is valid haskell."
, parDoc $ "There is NO WARRANTY, to the extent permitted by law." , parDoc $ "There is NO WARRANTY, to the extent permitted by law."
, parDoc $ "See https://github.com/lspitzner/brittany" , parDoc $ "See https://github.com/lspitzner/brittany"
, parDoc $ "Please report bugs at" , parDoc $ "Please report bugs at" ++ " https://github.com/lspitzner/brittany/issues"
++ " https://github.com/lspitzner/brittany/issues"
] ]
-- addCmd "debugArgs" $ do -- addCmd "debugArgs" $ do
addHelpCommand helpDesc addHelpCommand helpDesc
@ -71,7 +72,10 @@ mainCmdParser helpDesc = do
outputPaths <- addFlagStringParams "o" ["output"] "PATH" (flagHelpStr "output file path") outputPaths <- addFlagStringParams "o" ["output"] "PATH" (flagHelpStr "output file path")
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 <- configParser cmdlineConfig <- configParser
suppressOutput <- addSimpleBoolFlag "" ["suppress-output"] (flagHelp $ parDoc "suppress the regular output, i.e. the transformed haskell source") 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]") _verbosity <- addSimpleCountFlag "v" ["verbose"] (flagHelp $ parDoc "[currently without effect; TODO]")
reorderStop reorderStop
inputParam <- addStringParamOpt "PATH" (paramHelpStr "path to input haskell source file") inputParam <- addStringParamOpt "PATH" (paramHelpStr "path to input haskell source file")
@ -105,16 +109,9 @@ mainCmdParser helpDesc = do
Just x -> return x Just x -> return x
when (confUnpack $ _dconf_dump_config $ _conf_debug $ config) $ do when (confUnpack $ _dconf_dump_config $ _conf_debug $ config) $ do
trace (showConfigYaml config) $ return () trace (showConfigYaml config) $ return ()
let ghcOptions = config let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
& _conf_forward
& _options_ghc
& runIdentity
liftIO $ do liftIO $ do
let cppMode = config let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & runIdentity & Semigroup.getLast
& _conf_preprocessor
& _ppconf_CPPMode
& runIdentity
& Semigroup.getLast
-- the flag will do the following: insert a marker string -- the flag will do the following: insert a marker string
-- ("-- BRITTANY_INCLUDE_HACK ") right before any lines starting with -- ("-- BRITTANY_INCLUDE_HACK ") right before any lines starting with
-- "#include" before processing (parsing) input; and remove that marker -- "#include" before processing (parsing) input; and remove that marker
@ -132,8 +129,7 @@ mainCmdParser helpDesc = do
++ " brittany cannot check that its output is syntactically" ++ " brittany cannot check that its output is syntactically"
++ " valid in its presence." ++ " valid in its presence."
return $ Right True return $ Right True
CPPModeNowarn -> CPPModeNowarn -> return $ Right True
return $ Right True
else return $ Right False else return $ Right False
parseResult <- case inputPathM of parseResult <- case inputPathM of
Nothing -> do Nothing -> do
@ -170,12 +166,10 @@ mainCmdParser helpDesc = do
customErrOrder LayoutErrorUnusedComment{} = 2 customErrOrder LayoutErrorUnusedComment{} = 2
customErrOrder LayoutErrorUnknownNode{} = 3 customErrOrder LayoutErrorUnknownNode{} = 3
when (not $ null errsWarns) $ do when (not $ null errsWarns) $ do
let groupedErrsWarns = Data.List.Extra.groupOn customErrOrder let groupedErrsWarns = Data.List.Extra.groupOn customErrOrder $ List.sortOn customErrOrder $ errsWarns
$ List.sortOn customErrOrder
$ errsWarns
groupedErrsWarns `forM_` \case groupedErrsWarns `forM_` \case
(LayoutErrorOutputCheck{}:_) -> do (LayoutErrorOutputCheck{}:_) -> do
putStrErrLn $ "ERROR: brittany pretty printer returned syntactically invalid result." putStrErrLn $ "ERROR: brittany pretty printer" ++ " returned syntactically invalid result."
uns@(LayoutErrorUnknownNode{}:_) -> do uns@(LayoutErrorUnknownNode{}:_) -> do
putStrErrLn $ "ERROR: encountered unknown syntactical constructs:" putStrErrLn $ "ERROR: encountered unknown syntactical constructs:"
uns `forM_` \case uns `forM_` \case
@ -190,9 +184,11 @@ mainCmdParser helpDesc = do
LayoutWarning str -> putStrErrLn str LayoutWarning str -> putStrErrLn str
_ -> error "cannot happen (TM)" _ -> error "cannot happen (TM)"
unused@(LayoutErrorUnusedComment{}:_) -> do unused@(LayoutErrorUnusedComment{}:_) -> do
putStrErrLn $ "Error: detected unprocessed comments. the transformation " putStrErrLn
++ "output will most likely not contain certain of the comments " $ "Error: detected unprocessed comments."
++ "present in the input haskell source file." ++ " The transformation output will most likely"
++ " not contain certain of the comments"
++ " present in the input haskell source file."
putStrErrLn $ "Affected are the following comments:" putStrErrLn $ "Affected are the following comments:"
unused `forM_` \case unused `forM_` \case
LayoutErrorUnusedComment str -> putStrErrLn str LayoutErrorUnusedComment str -> putStrErrLn str
@ -200,27 +196,20 @@ mainCmdParser helpDesc = do
[] -> error "cannot happen" [] -> error "cannot happen"
-- TODO: don't output anything when there are errors unless user -- TODO: don't output anything when there are errors unless user
-- adds some override? -- adds some override?
let hasErrors = case config let hasErrors = case config & _conf_errorHandling & _econf_Werror & confUnpack of
& _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
outputOnErrs = config outputOnErrs = config & _conf_errorHandling & _econf_produceOutputOnErrors & confUnpack
& _conf_errorHandling shouldOutput = not suppressOutput && (not hasErrors || outputOnErrs)
& _econf_produceOutputOnErrors
& confUnpack
let shouldOutput = not suppressOutput
&& (not hasErrors || outputOnErrs)
when shouldOutput $ addTraceSep (_conf_debug config) $ case outputPath of when shouldOutput $ addTraceSep (_conf_debug config) $ case outputPath of
Nothing -> TextL.IO.putStr $ outLText Nothing -> TextL.IO.putStr $ outLText
Just p -> TextL.IO.writeFile p $ outLText Just p -> TextL.IO.writeFile p $ outLText
when hasErrors $ when hasErrors $ System.Exit.exitWith (System.Exit.ExitFailure 70)
System.Exit.exitWith (System.Exit.ExitFailure 70)
where where
addTraceSep conf = if or addTraceSep conf =
if or
[ confUnpack $ _dconf_dump_annotations conf [ confUnpack $ _dconf_dump_annotations conf
, confUnpack $ _dconf_dump_ast_unknown conf , confUnpack $ _dconf_dump_ast_unknown conf
, confUnpack $ _dconf_dump_ast_full conf , confUnpack $ _dconf_dump_ast_full conf
@ -246,7 +235,5 @@ readConfigs cmdlineConfig configPaths = do
>>= readMergePersConfig defLocalConfigPath False >>= readMergePersConfig defLocalConfigPath False
>>= readMergePersConfig defUserConfigPath True >>= readMergePersConfig defUserConfigPath True
-- TODO: ensure that paths exist ? -- TODO: ensure that paths exist ?
paths -> foldl (\prev p -> prev >>= readMergePersConfig p False) paths -> foldl (\prev p -> prev >>= readMergePersConfig p False) (return cmdlineConfig) paths
(return cmdlineConfig)
paths
return $ cZipWith fromOptionIdentity staticDefaultConfig merged return $ cZipWith fromOptionIdentity staticDefaultConfig merged