Auto-reformat Main.hs
Lennart Spitzner
parent
fd9427754e
commit
72c87b7b4e
|
|
@ -46,36 +46,40 @@ main = mainFromCmdParserWithHelpDesc mainCmdParser
|
|||
mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) ()
|
||||
mainCmdParser helpDesc = do
|
||||
addCmdSynopsis "haskell source pretty printer"
|
||||
addCmdHelp $ PP.vcat $ List.intersperse (PP.text "")
|
||||
[ parDoc $ "Transforms one haskell module by reformatting"
|
||||
++ " (parts of) the source code (while preserving the"
|
||||
++ " parts not transformed)."
|
||||
, parDoc $ "Based on ghc-exactprint, thus (theoretically) supporting all"
|
||||
++ " that ghc does."
|
||||
, parDoc $ "This is an early, experimental release."
|
||||
++ " Only type-signatures and function-bindings are transformed."
|
||||
++ " There is a check in place, but no warranties that the output"
|
||||
++ " is valid haskell."
|
||||
addCmdHelp $ PP.vcat $ List.intersperse
|
||||
(PP.text "")
|
||||
[ parDoc
|
||||
$ "Transforms one haskell module by reformatting"
|
||||
++ " (parts of) the source code (while preserving the"
|
||||
++ " parts not transformed)."
|
||||
, parDoc $ "Based on ghc-exactprint, thus (theoretically) supporting all" ++ " that ghc does."
|
||||
, parDoc
|
||||
$ "This is an early, experimental release."
|
||||
++ " Only type-signatures and function-bindings are transformed."
|
||||
++ " There is a check in place, but no warranties that the output"
|
||||
++ " is valid haskell."
|
||||
, parDoc $ "There is NO WARRANTY, to the extent permitted by law."
|
||||
, 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"
|
||||
]
|
||||
-- addCmd "debugArgs" $ do
|
||||
addHelpCommand helpDesc
|
||||
-- addButcherDebugCommand
|
||||
reorderStart
|
||||
printHelp <- addSimpleBoolFlag "" ["help"] mempty
|
||||
printVersion <- addSimpleBoolFlag "" ["version"] mempty
|
||||
inputPaths <- addFlagStringParams "i" ["input"] "PATH" (flagHelpStr "path to input haskell source file")
|
||||
outputPaths <- addFlagStringParams "o" ["output"] "PATH" (flagHelpStr "output file path")
|
||||
configPaths <- addFlagStringParams "" ["config-file"] "PATH" (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ?
|
||||
cmdlineConfig <- configParser
|
||||
suppressOutput <- addSimpleBoolFlag "" ["suppress-output"] (flagHelp $ parDoc "suppress the regular output, i.e. the transformed haskell source")
|
||||
printHelp <- addSimpleBoolFlag "" ["help"] mempty
|
||||
printVersion <- addSimpleBoolFlag "" ["version"] mempty
|
||||
inputPaths <- addFlagStringParams "i" ["input"] "PATH" (flagHelpStr "path to input haskell source file")
|
||||
outputPaths <- addFlagStringParams "o" ["output"] "PATH" (flagHelpStr "output file path")
|
||||
configPaths <- addFlagStringParams "" ["config-file"] "PATH" (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ?
|
||||
cmdlineConfig <- configParser
|
||||
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]")
|
||||
reorderStop
|
||||
inputParam <- addStringParamOpt "PATH" (paramHelpStr "path to input haskell source file")
|
||||
desc <- peekCmdDesc
|
||||
desc <- peekCmdDesc
|
||||
addCmdImpl $ void $ do
|
||||
when printVersion $ do
|
||||
liftIO $ do
|
||||
|
|
@ -90,31 +94,24 @@ mainCmdParser helpDesc = do
|
|||
[] -> do
|
||||
return Nothing
|
||||
[x] -> return $ Just x
|
||||
_ -> do
|
||||
_ -> do
|
||||
liftIO $ putStrErrLn $ "more than one input, aborting"
|
||||
System.Exit.exitWith (System.Exit.ExitFailure 50)
|
||||
outputPath <- case outputPaths of
|
||||
[] -> do
|
||||
return Nothing
|
||||
[x] -> return $ Just x
|
||||
_ -> do
|
||||
_ -> do
|
||||
liftIO $ putStrErrLn $ "more than one output, aborting"
|
||||
System.Exit.exitWith (System.Exit.ExitFailure 50)
|
||||
config <- runMaybeT (readConfigs cmdlineConfig configPaths) >>= \case
|
||||
Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 50)
|
||||
Just x -> return x
|
||||
Just x -> return x
|
||||
when (confUnpack $ _dconf_dump_config $ _conf_debug $ config) $ do
|
||||
trace (showConfigYaml config) $ return ()
|
||||
let ghcOptions = config
|
||||
& _conf_forward
|
||||
& _options_ghc
|
||||
& runIdentity
|
||||
let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
|
||||
liftIO $ do
|
||||
let cppMode = config
|
||||
& _conf_preprocessor
|
||||
& _ppconf_CPPMode
|
||||
& runIdentity
|
||||
& Semigroup.getLast
|
||||
let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & runIdentity & Semigroup.getLast
|
||||
-- the flag will do the following: insert a marker string
|
||||
-- ("-- BRITTANY_INCLUDE_HACK ") right before any lines starting with
|
||||
-- "#include" before processing (parsing) input; and remove that marker
|
||||
|
|
@ -132,8 +129,7 @@ mainCmdParser helpDesc = do
|
|||
++ " brittany cannot check that its output is syntactically"
|
||||
++ " valid in its presence."
|
||||
return $ Right True
|
||||
CPPModeNowarn ->
|
||||
return $ Right True
|
||||
CPPModeNowarn -> return $ Right True
|
||||
else return $ Right False
|
||||
parseResult <- case inputPathM of
|
||||
Nothing -> do
|
||||
|
|
@ -170,12 +166,10 @@ mainCmdParser helpDesc = do
|
|||
customErrOrder LayoutErrorUnusedComment{} = 2
|
||||
customErrOrder LayoutErrorUnknownNode{} = 3
|
||||
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
|
||||
(LayoutErrorOutputCheck{}:_) -> do
|
||||
putStrErrLn $ "ERROR: brittany pretty printer returned syntactically invalid result."
|
||||
putStrErrLn $ "ERROR: brittany pretty printer" ++ " returned syntactically invalid result."
|
||||
uns@(LayoutErrorUnknownNode{}:_) -> do
|
||||
putStrErrLn $ "ERROR: encountered unknown syntactical constructs:"
|
||||
uns `forM_` \case
|
||||
|
|
@ -188,49 +182,44 @@ mainCmdParser helpDesc = do
|
|||
putStrErrLn $ "WARNINGS:"
|
||||
warns `forM_` \case
|
||||
LayoutWarning str -> putStrErrLn str
|
||||
_ -> error "cannot happen (TM)"
|
||||
_ -> error "cannot happen (TM)"
|
||||
unused@(LayoutErrorUnusedComment{}:_) -> do
|
||||
putStrErrLn $ "Error: detected unprocessed comments. the transformation "
|
||||
++ "output will most likely not contain certain of the comments "
|
||||
++ "present in the input haskell source file."
|
||||
putStrErrLn
|
||||
$ "Error: detected unprocessed comments."
|
||||
++ " 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:"
|
||||
unused `forM_` \case
|
||||
LayoutErrorUnusedComment str -> putStrErrLn str
|
||||
_ -> error "cannot happen (TM)"
|
||||
_ -> error "cannot happen (TM)"
|
||||
[] -> 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
|
||||
let shouldOutput = not suppressOutput
|
||||
&& (not hasErrors || outputOnErrs)
|
||||
outputOnErrs = config & _conf_errorHandling & _econf_produceOutputOnErrors & confUnpack
|
||||
shouldOutput = not suppressOutput && (not hasErrors || outputOnErrs)
|
||||
|
||||
when shouldOutput $ addTraceSep (_conf_debug config) $ case outputPath of
|
||||
Nothing -> TextL.IO.putStr $ outLText
|
||||
Just p -> TextL.IO.writeFile p $ outLText
|
||||
Nothing -> TextL.IO.putStr $ outLText
|
||||
Just p -> TextL.IO.writeFile p $ outLText
|
||||
|
||||
when hasErrors $
|
||||
System.Exit.exitWith (System.Exit.ExitFailure 70)
|
||||
where
|
||||
addTraceSep conf = if or
|
||||
[ confUnpack $ _dconf_dump_annotations conf
|
||||
, confUnpack $ _dconf_dump_ast_unknown conf
|
||||
, confUnpack $ _dconf_dump_ast_full conf
|
||||
, confUnpack $ _dconf_dump_bridoc_raw conf
|
||||
, confUnpack $ _dconf_dump_bridoc_simpl_alt conf
|
||||
, confUnpack $ _dconf_dump_bridoc_simpl_floating conf
|
||||
, confUnpack $ _dconf_dump_bridoc_simpl_columns conf
|
||||
, confUnpack $ _dconf_dump_bridoc_simpl_indent conf
|
||||
, confUnpack $ _dconf_dump_bridoc_final conf
|
||||
]
|
||||
when hasErrors $ System.Exit.exitWith (System.Exit.ExitFailure 70)
|
||||
where
|
||||
addTraceSep conf =
|
||||
if or
|
||||
[ confUnpack $ _dconf_dump_annotations conf
|
||||
, confUnpack $ _dconf_dump_ast_unknown conf
|
||||
, confUnpack $ _dconf_dump_ast_full conf
|
||||
, confUnpack $ _dconf_dump_bridoc_raw conf
|
||||
, confUnpack $ _dconf_dump_bridoc_simpl_alt conf
|
||||
, confUnpack $ _dconf_dump_bridoc_simpl_floating conf
|
||||
, confUnpack $ _dconf_dump_bridoc_simpl_columns conf
|
||||
, confUnpack $ _dconf_dump_bridoc_simpl_indent conf
|
||||
, confUnpack $ _dconf_dump_bridoc_final conf
|
||||
]
|
||||
then trace "----"
|
||||
else id
|
||||
|
||||
|
|
@ -240,13 +229,11 @@ readConfigs cmdlineConfig configPaths = do
|
|||
userBritPath <- liftIO $ Directory.getAppUserDataDirectory "brittany"
|
||||
let defUserConfigPath = userBritPath FilePath.</> "config.yaml"
|
||||
merged <- case configPaths of
|
||||
[] -> do
|
||||
[] -> do
|
||||
liftIO $ Directory.createDirectoryIfMissing False userBritPath
|
||||
return cmdlineConfig
|
||||
>>= readMergePersConfig defLocalConfigPath False
|
||||
>>= readMergePersConfig defUserConfigPath True
|
||||
-- TODO: ensure that paths exist ?
|
||||
paths -> foldl (\prev p -> prev >>= readMergePersConfig p False)
|
||||
(return cmdlineConfig)
|
||||
paths
|
||||
paths -> foldl (\prev p -> prev >>= readMergePersConfig p False) (return cmdlineConfig) paths
|
||||
return $ cZipWith fromOptionIdentity staticDefaultConfig merged
|
||||
|
|
|
|||
Loading…
Reference in New Issue