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

Refactor Main.hs in preparation of --inplace (see #40)

pull/51/head
Lennart Spitzner 2017-08-08 00:46:09 +02:00
parent 91b9a240f1
commit 69c50bebd3
1 changed files with 129 additions and 110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

81
src-brittany/Main.hs
View File

@ -90,6 +90,7 @@ licenseDoc = PP.vcat $ List.intersperse
]
]
mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) ()
mainCmdParser helpDesc = do
addCmdSynopsis "haskell source pretty printer"
@ -116,10 +117,10 @@ mainCmdParser helpDesc = do
desc <- peekCmdDesc
addCmdImpl $ void $ do
when printLicense $ do
liftIO $ print licenseDoc
print licenseDoc
System.Exit.exitSuccess
when printVersion $ do
liftIO $ do
do
putStrLn $ "brittany version " ++ showVersion version
putStrLn $ "Copyright (C) 2016-2017 Lennart Spitzner"
putStrLn $ "There is NO WARRANTY, to the extent permitted by law."
@ -132,22 +133,41 @@ mainCmdParser helpDesc = do
return Nothing
[x] -> return $ Just x
_ -> do
liftIO $ putStrErrLn $ "more than one input, aborting"
putStrErrLn $ "more than one input, aborting"
System.Exit.exitWith (System.Exit.ExitFailure 50)
outputPath <- case outputPaths of
outputPathM <- case outputPaths of
[] -> do
return Nothing
[x] -> return $ Just x
_ -> do
liftIO $ putStrErrLn $ "more than one output, aborting"
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
when (confUnpack $ _dconf_dump_config $ _conf_debug $ config) $ do
trace (showConfigYaml config) $ return ()
eitherErrSucc <- coreIO putStrErrLn config suppressOutput inputPathM outputPathM
case eitherErrSucc of
Left errNo -> System.Exit.exitWith (System.Exit.ExitFailure errNo)
Right () -> pure ()
-- | The main IO parts for the default mode of operation, and after commandline
-- and config stuff is processed.
coreIO
:: (String -> IO ()) -- ^ error output function. In parallel operation, you
-- may want serialize the different outputs and
-- consequently not directly print to stderr.
-> Config -- ^ global program config.
-> Bool -- ^ whether to supress output (to stdout). Purely IO flag, so
-- currently not part of program config.
-> 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 = EitherT.runEitherT $ do
let putErrorLn = liftIO . putErrorLnIO :: String -> EitherT.EitherT e IO ()
let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
liftIO $ do
-- there is a good of code duplication between the following code and the
-- `pureModuleTransform` function. Unfortunately, there are also a good
-- amount of slight differences: This module is a bit more verbose, and
@ -165,7 +185,7 @@ mainCmdParser helpDesc = do
CPPModeAbort -> do
return $ Left "Encountered -XCPP. Aborting."
CPPModeWarn -> do
putStrErrLn
putErrorLnIO
$ "Warning: Encountered -XCPP."
++ " Be warned that -XCPP is not supported and that"
++ " brittany cannot check that its output is syntactically"
@ -179,14 +199,14 @@ mainCmdParser helpDesc = do
let hackF s = if "#include" `isPrefixOf` s then "-- BRITTANY_INCLUDE_HACK " ++ s else s
let hackTransform =
if hackAroundIncludes && not exactprintOnly then List.unlines . fmap hackF . List.lines else id
inputString <- System.IO.hGetContents System.IO.stdin
parseModuleFromString ghcOptions "stdin" cppCheckFunc (hackTransform inputString)
Just p -> parseModule ghcOptions p cppCheckFunc
inputString <- liftIO $ System.IO.hGetContents System.IO.stdin
liftIO $ parseModuleFromString ghcOptions "stdin" cppCheckFunc (hackTransform inputString)
Just p -> liftIO $ parseModule ghcOptions p cppCheckFunc
case parseResult of
Left left -> do
putStrErrLn "parse error:"
printErr left
System.Exit.exitWith (System.Exit.ExitFailure 60)
putErrorLn "parse error:"
putErrorLn $ show left
EitherT.left 60
Right (anns, parsedSource, hasCPP) -> do
when (config & _conf_debug .> _dconf_dump_ast_full .> confUnpack) $ do
let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource
@ -199,11 +219,9 @@ mainCmdParser helpDesc = do
let omitCheck = config & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack
(ews, outRaw) <- if hasCPP || omitCheck
then return $ pPrintModule config anns parsedSource
else pPrintModuleAndCheck config anns parsedSource
else liftIO $ pPrintModuleAndCheck config anns parsedSource
let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITTANY_INCLUDE_HACK ") s
pure $ if hackAroundIncludes
then (ews, TextL.unlines $ fmap hackF $ TextL.lines outRaw)
else (ews, outRaw)
pure $ if hackAroundIncludes then (ews, TextL.unlines $ fmap hackF $ TextL.lines outRaw) else (ews, outRaw)
let customErrOrder ErrorInput{} = 4
customErrOrder LayoutWarning{} = 0 :: Int
customErrOrder ErrorOutputCheck{} = 1
@ -213,31 +231,31 @@ mainCmdParser helpDesc = do
let groupedErrsWarns = Data.List.Extra.groupOn customErrOrder $ List.sortOn customErrOrder $ errsWarns
groupedErrsWarns `forM_` \case
(ErrorOutputCheck{}:_) -> do
putStrErrLn $ "ERROR: brittany pretty printer" ++ " returned syntactically invalid result."
putErrorLn $ "ERROR: brittany pretty printer" ++ " returned syntactically invalid result."
(ErrorInput str:_) -> do
putStrErrLn $ "ERROR: parse error: " ++ str
putErrorLn $ "ERROR: parse error: " ++ str
uns@(ErrorUnknownNode{}:_) -> do
putStrErrLn $ "ERROR: encountered unknown syntactical constructs:"
putErrorLn $ "ERROR: encountered unknown syntactical constructs:"
uns `forM_` \case
ErrorUnknownNode str ast -> do
putStrErrLn str
putErrorLn str
when (config & _conf_debug & _dconf_dump_ast_unknown & confUnpack) $ do
putStrErrLn $ " " ++ show (astToDoc ast)
putErrorLn $ " " ++ show (astToDoc ast)
_ -> error "cannot happen (TM)"
warns@(LayoutWarning{}:_) -> do
putStrErrLn $ "WARNINGS:"
putErrorLn $ "WARNINGS:"
warns `forM_` \case
LayoutWarning str -> putStrErrLn str
LayoutWarning str -> putErrorLn str
_ -> error "cannot happen (TM)"
unused@(ErrorUnusedComment{}:_) -> do
putStrErrLn
putErrorLn
$ "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:"
putErrorLn $ "Affected are the following comments:"
unused `forM_` \case
ErrorUnusedComment str -> putStrErrLn str
ErrorUnusedComment str -> putErrorLn str
_ -> error "cannot happen (TM)"
[] -> error "cannot happen"
-- TODO: don't output anything when there are errors unless user
@ -248,11 +266,11 @@ mainCmdParser helpDesc = do
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
when shouldOutput $ addTraceSep (_conf_debug config) $ case outputPathM of
Nothing -> liftIO $ TextL.IO.putStr $ outLText
Just p -> liftIO $ TextL.IO.writeFile p $ outLText
when hasErrors $ System.Exit.exitWith (System.Exit.ExitFailure 70)
when hasErrors $ EitherT.left 70
where
addTraceSep conf =
if or
@ -269,6 +287,7 @@ mainCmdParser helpDesc = do
then trace "----"
else id
readConfigs :: CConfig Option -> [System.IO.FilePath] -> MaybeT IO Config
readConfigs cmdlineConfig configPaths = do
let defLocalConfigPath = "brittany.yaml"