From 69c50bebd3c5a34c85326ae0f5a611feea0b12ad Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 8 Aug 2017 00:46:09 +0200 Subject: [PATCH] Refactor Main.hs in preparation of --inplace (see #40) --- src-brittany/Main.hs | 239 +++++++++++++++++++++++-------------------- 1 file changed, 129 insertions(+), 110 deletions(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 0acdaff..9f0dbc5 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -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,127 +133,144 @@ 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 () - 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 - -- it tries to use the full-blown `parseModule` function which supports - -- CPP (but requires the input to be a file..). - let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack - -- 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 - -- string from the transformation output. - let hackAroundIncludes = config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack - let exactprintOnly = 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." - CPPModeWarn -> do - putStrErrLn - $ "Warning: Encountered -XCPP." - ++ " Be warned that -XCPP is not supported and that" - ++ " brittany cannot check that its output is syntactically" - ++ " valid in its presence." - return $ Right True - CPPModeNowarn -> return $ Right True - else return $ Right False - 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 "-- 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 - case parseResult of - Left left -> do - putStrErrLn "parse error:" - printErr left - System.Exit.exitWith (System.Exit.ExitFailure 60) - Right (anns, parsedSource, hasCPP) -> 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, outLText) <- do - if exactprintOnly - then do - pure ([], TextL.pack $ ExactPrint.exactPrint parsedSource anns) - else 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 - 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) - let customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = 0 :: Int - customErrOrder ErrorOutputCheck{} = 1 - customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = 3 - when (not $ null errsWarns) $ 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." - (ErrorInput str:_) -> do - putStrErrLn $ "ERROR: parse error: " ++ str - uns@(ErrorUnknownNode{}:_) -> do - putStrErrLn $ "ERROR: encountered unknown syntactical constructs:" - uns `forM_` \case - ErrorUnknownNode str ast -> do - putStrErrLn str - when (config & _conf_debug & _dconf_dump_ast_unknown & confUnpack) $ do - putStrErrLn $ " " ++ show (astToDoc ast) - _ -> error "cannot happen (TM)" - warns@(LayoutWarning{}:_) -> do - putStrErrLn $ "WARNINGS:" - warns `forM_` \case - LayoutWarning str -> putStrErrLn str - _ -> error "cannot happen (TM)" - unused@(ErrorUnusedComment{}:_) -> 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 $ "Affected are the following comments:" - unused `forM_` \case - ErrorUnusedComment str -> putStrErrLn str - _ -> 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 - False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) - True -> not $ null errsWarns - outputOnErrs = config & _conf_errorHandling & _econf_produceOutputOnErrors & confUnpack - shouldOutput = not suppressOutput && (not hasErrors || outputOnErrs) + eitherErrSucc <- coreIO putStrErrLn config suppressOutput inputPathM outputPathM + case eitherErrSucc of + Left errNo -> System.Exit.exitWith (System.Exit.ExitFailure errNo) + Right () -> pure () - when shouldOutput $ addTraceSep (_conf_debug config) $ case outputPath of - Nothing -> TextL.IO.putStr $ outLText - Just p -> TextL.IO.writeFile p $ outLText - when hasErrors $ System.Exit.exitWith (System.Exit.ExitFailure 70) +-- | 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 + -- 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 + -- it tries to use the full-blown `parseModule` function which supports + -- CPP (but requires the input to be a file..). + let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack + -- 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 + -- string from the transformation output. + let hackAroundIncludes = config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack + let exactprintOnly = 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." + CPPModeWarn -> do + putErrorLnIO + $ "Warning: Encountered -XCPP." + ++ " Be warned that -XCPP is not supported and that" + ++ " brittany cannot check that its output is syntactically" + ++ " valid in its presence." + return $ Right True + CPPModeNowarn -> return $ Right True + else return $ Right False + 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 "-- BRITTANY_INCLUDE_HACK " ++ s else s + let hackTransform = + if hackAroundIncludes && not exactprintOnly then List.unlines . fmap hackF . List.lines else id + 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 + 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 + trace ("---- ast ----\n" ++ show val) $ return () + (errsWarns, outLText) <- do + if exactprintOnly + then do + pure ([], TextL.pack $ ExactPrint.exactPrint parsedSource anns) + else do + let omitCheck = config & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack + (ews, outRaw) <- if hasCPP || omitCheck + then return $ pPrintModule 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) + let customErrOrder ErrorInput{} = 4 + customErrOrder LayoutWarning{} = 0 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnknownNode{} = 3 + when (not $ null errsWarns) $ do + 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 + putErrorLn $ "ERROR: parse error: " ++ str + 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 + putErrorLn $ " " ++ show (astToDoc ast) + _ -> error "cannot happen (TM)" + warns@(LayoutWarning{}:_) -> do + putErrorLn $ "WARNINGS:" + warns `forM_` \case + LayoutWarning str -> putErrorLn str + _ -> error "cannot happen (TM)" + unused@(ErrorUnusedComment{}:_) -> do + putErrorLn + $ "Error: detected unprocessed comments." + ++ " The transformation output will most likely" + ++ " not contain certain of the comments" + ++ " present in the input haskell source file." + putErrorLn $ "Affected are the following comments:" + unused `forM_` \case + ErrorUnusedComment str -> putErrorLn str + _ -> 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 + False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) + True -> not $ null errsWarns + outputOnErrs = config & _conf_errorHandling & _econf_produceOutputOnErrors & confUnpack + shouldOutput = not suppressOutput && (not hasErrors || outputOnErrs) + + 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 $ 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"