{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} module Language.Haskell.Brittany.Main where import Control.Monad (zipWithM) import qualified Control.Monad.Trans.Except as ExceptT import qualified Data.Either import qualified Data.List.Extra import qualified Data.Monoid import qualified Data.Text.IO as Text.IO import GHC (GenLocated(L)) import qualified GHC import qualified GHC.OldList as List import GHC.Utils.Outputable (Outputable(..), showSDocUnsafe) import Language.Haskell.Brittany.Internal import Language.Haskell.Brittany.Internal.Config.Config import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Utils import Paths_brittany import qualified System.Directory as Directory import qualified System.Environment as Environment import qualified System.Exit import qualified System.FilePath.Posix as FilePath import qualified System.IO import qualified Text.ParserCombinators.ReadP as ReadP import qualified Text.ParserCombinators.ReadPrec as ReadPrec import qualified Text.PrettyPrint as PP import Text.Read (Read(..)) import UI.Butcher.Monadic data WriteMode = Display | Inplace instance Read WriteMode where readPrec = val "display" Display <|> val "inplace" Inplace where val iden v = ReadPrec.lift $ ReadP.string iden >> return v instance Show WriteMode where show Display = "display" show Inplace = "inplace" main :: IO () main = do progName <- Environment.getProgName args <- Environment.getArgs mainWith progName args testMain :: IO () testMain = do h <- System.IO.openFile "local/sample-folder/err.txt" System.IO.WriteMode let cmdlineR = runCmdParser Nothing (InputArgs [ "--output-on-errors" , "--dump-ast-full" , "--omit-output-check" -- , "--dump-bridoc-alt" , "--dump-bridoc-floating" -- , "--dump-bridoc-par" -- , "--dump-bridoc-columns" , "--dump-bridoc-final" ] ) $ do reorderStart c <- cmdlineConfigParser reorderStop addCmdImpl c let cmdlineConfig = case _ppi_value cmdlineR of Left err -> error (show err) Right (Nothing) -> error "could not parse config" Right (Just r ) -> r configsToLoad <- maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath) config <- runMaybeT (readConfigs cmdlineConfig configsToLoad) -- (readConfigsWithUserConfig cmdlineConfig configsToLoad) >>= \case Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) Just x -> return x System.IO.hPutStrLn h $ showConfigYaml config e <- coreIO (System.IO.hPutStrLn h) config False False (Just "local/sample-folder/Test.hs") (Just "local/sample-folder/out.txt") case e of Left i -> print i Right Changes -> putStrLn "Changes" Right NoChanges -> putStrLn "NoChanges" mainWith :: String -> [String] -> IO () mainWith progName args = Environment.withProgName progName . Environment.withArgs args $ mainFromCmdParser mainCmdParser helpDoc :: PP.Doc helpDoc = PP.vcat $ List.intersperse (PP.text "") [ parDocW [ "Reformats one or more haskell modules." , "Currently affects only the module head (imports/exports), type" , "signatures and function bindings;" , "everything else is left unmodified." , "Based on ghc-exactprint, thus (theoretically) supporting all" , "that ghc does." ] , parDoc $ "Example invocations:" , PP.hang (PP.text "") 2 $ PP.vcat [ PP.text "brittany" , PP.nest 2 $ PP.text "read from stdin, output to stdout" ] , PP.hang (PP.text "") 2 $ PP.vcat [ PP.text "brittany --indent=4 --write-mode=inplace *.hs" , PP.nest 2 $ PP.vcat [ PP.text "run on all modules in current directory (no backup!)" , PP.text "4 spaces indentation" ] ] , parDocW [ "This program is written carefully and contains safeguards to ensure" , "the output is syntactically valid and that no comments are removed." , "Nonetheless, this is a young project, and there will always be bugs," , "and ensuring that the transformation never changes semantics of the" , "transformed source is currently not possible." , "Please do check the output and do not let brittany override your large" , "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." ] , parDoc $ "See https://github.com/lspitzner/brittany" , parDoc $ "Please report bugs at" ++ " https://github.com/lspitzner/brittany/issues" ] licenseDoc :: PP.Doc licenseDoc = PP.vcat $ List.intersperse (PP.text "") [ parDoc $ "Copyright (C) 2016-2019 Lennart Spitzner" , parDoc $ "Copyright (C) 2019 PRODA LTD" , parDocW [ "This program is free software: you can redistribute it and/or modify" , "it under the terms of the GNU Affero General Public License," , "version 3, as published by the Free Software Foundation." ] , parDocW [ "This program is distributed in the hope that it will be useful," , "but WITHOUT ANY WARRANTY; without even the implied warranty of" , "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" , "GNU Affero General Public License for more details." ] , parDocW [ "You should have received a copy of the GNU Affero General Public" , "License along with this program. If not, see" , "." ] ] mainCmdParser :: CmdParser Identity (IO ()) () mainCmdParser = do helpDesc <- peekCmdDesc addCmdSynopsis "haskell source pretty printer" addCmdHelp $ helpDoc -- addCmd "debugArgs" $ do addHelpCommand helpDesc addCmd "license" $ addCmdImpl $ print $ licenseDoc -- addButcherDebugCommand reorderStart printHelp <- addSimpleBoolFlag "h" ["help"] mempty printVersion <- addSimpleBoolFlag "" ["version"] mempty printLicense <- addSimpleBoolFlag "" ["license"] mempty noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty 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]") checkMode <- addSimpleBoolFlag "c" ["check-mode"] (flagHelp (PP.vcat [ PP.text "check for changes but do not write them out" , PP.text "exits with code 0 if no changes necessary, 1 otherwise" , PP.text "and print file path(s) of files that have changes to stdout" ] ) ) writeMode <- addFlagReadParam "" ["write-mode"] "(display|inplace)" (flagHelp (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") reorderStop addCmdImpl $ void $ do when printLicense $ do print licenseDoc System.Exit.exitSuccess when printVersion $ do do putStrLn $ "brittany version " ++ showVersion version putStrLn $ "Copyright (C) 2016-2019 Lennart Spitzner" putStrLn $ "Copyright (C) 2019 PRODA LTD" 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 System.Exit.exitSuccess 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) else pure configPaths config <- runMaybeT (if noUserConfig then readConfigs cmdlineConfig configsToLoad else 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 () results <- zipWithM (coreIO putStrErrLn config suppressOutput checkMode) inputPaths outputPaths if checkMode then when (Changes `elem` (Data.Either.rights results)) $ System.Exit.exitWith (System.Exit.ExitFailure 1) else case results of xs | all Data.Either.isRight xs -> pure () [Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x) _ -> System.Exit.exitWith (System.Exit.ExitFailure 1) data ChangeStatus = Changes | NoChanges deriving (Eq) -- | 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. -> Bool -- ^ whether we are (just) in check mode. -> Maybe FilePath.FilePath -- ^ input filepath; stdin if Nothing. -> Maybe FilePath.FilePath -- ^ output filepath; stdout if Nothing. -> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status. coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = ExceptT.runExceptT $ do let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () inputVal <- case inputPathM of Nothing -> do inputString <- liftIO System.IO.getContents pure $ Right inputString Just p -> pure $ Left p let printErrorsAndWarnings errsWarns = do let customErrOrder ErrorInput{} = 4 customErrOrder LayoutWarning{} = -1 :: Int customErrOrder ErrorOutputCheck{} = 1 customErrOrder ErrorUnusedComment{} = 2 customErrOrder ErrorUnusedComments{} = 3 customErrOrder ErrorUnknownNode{} = -2 :: Int customErrOrder ErrorMacroConfig{} = 5 unless (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 $ "WARNING: encountered unknown syntactical constructs:" uns `forM_` \case ErrorUnknownNode str ast@(L loc _) -> do putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc) when (config & _conf_debug & _dconf_dump_ast_unknown & confUnpack ) $ do putErrorLn $ " " ++ show (astToDoc ast) _ -> error "cannot happen (TM)" putErrorLn " -> falling back on exactprint for this element of the module" 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 some 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)" unused@(ErrorUnusedComments{} : _) -> do unused `forM_` \case ErrorUnusedComments (L (GHC.SrcSpanAnn _ ann) _) cIn cOut -> do putErrorLn $ "Error: detected unprocessed comments (" ++ show cOut ++ " out of " ++ show cIn ++ ")." ++ " The transformation output will most likely" ++ " not contain some of the comments" ++ " present in the input haskell source file." putErrorLn $ "Affected is the declaration at " ++ show (astToDoc ann) _ -> error "cannot happen (TM)" (ErrorMacroConfig err input : _) -> do putErrorLn $ "Error: parse error in inline configuration:" putErrorLn err putErrorLn $ " in the string \"" ++ input ++ "\"." [] -> error "cannot happen" parseResult <- liftIO $ parsePrintModuleCommon (TraceFunc putErrorLnIO) config inputVal ( 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." ) case parseResult of Left errWarns@[ErrorInput{}] -> do printErrorsAndWarnings errWarns ExceptT.throwE 60 Left errWarns@(ErrorMacroConfig{}: _) -> do printErrorsAndWarnings errWarns ExceptT.throwE 61 Left errWarns -> do printErrorsAndWarnings errWarns ExceptT.throwE 70 Right (errsWarns, outSText, hasChangesAct) -> do printErrorsAndWarnings errsWarns hasChanges <- liftIO $ hasChangesAct -- TODO: don't output anything when there are errors unless user -- adds some override? let shouldOutput = not suppressOutput && not checkMode when shouldOutput $ addTraceSep (_conf_debug config) $ case outputPathM of Nothing -> liftIO $ Text.IO.putStr $ outSText Just p -> liftIO $ do let shouldWrite = case inputPathM of Nothing -> True Just p2 -> hasChanges || p /= p2 when shouldWrite $ Text.IO.writeFile p $ outSText when (checkMode && hasChanges) $ case inputPathM of Nothing -> pure () Just p -> liftIO $ putStrLn $ "formatting would modify: " ++ p return (if hasChanges then Changes else NoChanges) 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