{-# LANGUAGE DataKinds #-}

module Language.Haskell.Brittany.Main (main) where



#include "prelude.inc"

-- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 }
import qualified Language.Haskell.GHC.ExactPrint         as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Annotate
                                                         as ExactPrint.Annotate
import qualified Language.Haskell.GHC.ExactPrint.Types   as ExactPrint.Types
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers
import qualified Data.Map                                as Map
import qualified Data.Monoid

import           GHC                                      ( GenLocated(L) )
import           Outputable                               ( Outputable(..)
                                                          , showSDocUnsafe
                                                          )

import           Text.Read                                ( Read(..) )
import qualified Text.ParserCombinators.ReadP            as ReadP
import qualified Text.ParserCombinators.ReadPrec         as ReadPrec
import qualified Data.Text.Lazy.Builder                  as Text.Builder

import           Control.Monad                            ( zipWithM )
import           Data.CZipWith

import qualified Debug.Trace                             as Trace

import           Language.Haskell.Brittany.Internal.Types
import           Language.Haskell.Brittany.Internal
import           Language.Haskell.Brittany.Internal.Config
import           Language.Haskell.Brittany.Internal.Config.Types
import           Language.Haskell.Brittany.Internal.Utils
import           Language.Haskell.Brittany.Internal.Obfuscation

import qualified Text.PrettyPrint                        as PP

import           DataTreePrint
import           UI.Butcher.Monadic

import qualified System.Exit
import qualified System.Directory                        as Directory
import qualified System.FilePath.Posix                   as FilePath

import qualified DynFlags                                as GHC
import qualified GHC.LanguageExtensions.Type             as GHC

import           Paths_brittany



data WriteMode = Display | Inplace

instance Read WriteMode where
  readPrec :: ReadPrec WriteMode
readPrec = String -> WriteMode -> ReadPrec WriteMode
forall a. String -> a -> ReadPrec a
val String
"display" WriteMode
Display ReadPrec WriteMode -> ReadPrec WriteMode -> ReadPrec WriteMode
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> WriteMode -> ReadPrec WriteMode
forall a. String -> a -> ReadPrec a
val String
"inplace" WriteMode
Inplace
    where val :: String -> a -> ReadPrec a
val String
iden a
v = ReadP a -> ReadPrec a
forall a. ReadP a -> ReadPrec a
ReadPrec.lift (ReadP a -> ReadPrec a) -> ReadP a -> ReadPrec a
forall a b. (a -> b) -> a -> b
$ String -> ReadP String
ReadP.string String
iden ReadP String -> ReadP a -> ReadP a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v

instance Show WriteMode where
  show :: WriteMode -> String
show WriteMode
Display = String
"display"
  show WriteMode
Inplace = String
"inplace"


main :: IO ()
main :: IO ()
main = (CommandDesc () -> CmdParser Identity (IO ()) ()) -> IO ()
mainFromCmdParserWithHelpDesc CommandDesc () -> CmdParser Identity (IO ()) ()
mainCmdParser

helpDoc :: PP.Doc
helpDoc :: Doc
helpDoc = [Doc] -> Doc
PP.vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
List.intersperse
  (String -> Doc
PP.text String
"")
  [ [String] -> Doc
parDocW
    [ String
"Reformats one or more haskell modules."
    , String
"Currently affects only the module head (imports/exports), type"
    , String
"signatures and function bindings;"
    , String
"everything else is left unmodified."
    , String
"Based on ghc-exactprint, thus (theoretically) supporting all"
    , String
"that ghc does."
    ]
  , String -> Doc
parDoc (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"Example invocations:"
  , Doc -> Int -> Doc -> Doc
PP.hang (String -> Doc
PP.text String
"") Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
PP.vcat
    [ String -> Doc
PP.text String
"brittany"
    , Int -> Doc -> Doc
PP.nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text String
"read from stdin, output to stdout"
    ]
  , Doc -> Int -> Doc -> Doc
PP.hang (String -> Doc
PP.text String
"") Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
PP.vcat
    [ String -> Doc
PP.text String
"brittany --indent=4 --write-mode=inplace *.hs"
    , Int -> Doc -> Doc
PP.nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
PP.vcat
      [ String -> Doc
PP.text String
"run on all modules in current directory (no backup!)"
      , String -> Doc
PP.text String
"4 spaces indentation"
      ]
    ]
  , [String] -> Doc
parDocW
    [ String
"This program is written carefully and contains safeguards to ensure"
    , String
"the output is syntactically valid and that no comments are removed."
    , String
"Nonetheless, this is a young project, and there will always be bugs,"
    , String
"and ensuring that the transformation never changes semantics of the"
    , String
"transformed source is currently not possible."
    , String
"Please do check the output and do not let brittany override your large"
    , String
"codebase without having backups."
    ]
  , String -> Doc
parDoc (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"There is NO WARRANTY, to the extent permitted by law."
  , [String] -> Doc
parDocW
    [ String
"This program is free software released under the AGPLv3."
    , String
"For details use the --license flag."
    ]
  , String -> Doc
parDoc (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"See https://github.com/lspitzner/brittany"
  , String -> Doc
parDoc
  (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$  String
"Please report bugs at"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" https://github.com/lspitzner/brittany/issues"
  ]

licenseDoc :: PP.Doc
licenseDoc :: Doc
licenseDoc = [Doc] -> Doc
PP.vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
List.intersperse
  (String -> Doc
PP.text String
"")
  [ String -> Doc
parDoc (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"Copyright (C) 2016-2019 Lennart Spitzner"
  , String -> Doc
parDoc (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"Copyright (C) 2019 PRODA LTD"
  , [String] -> Doc
parDocW
    [ String
"This program is free software: you can redistribute it and/or modify"
    , String
"it under the terms of the GNU Affero General Public License,"
    , String
"version 3, as published by the Free Software Foundation."
    ]
  , [String] -> Doc
parDocW
    [ String
"This program is distributed in the hope that it will be useful,"
    , String
"but WITHOUT ANY WARRANTY; without even the implied warranty of"
    , String
"MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the"
    , String
"GNU Affero General Public License for more details."
    ]
  , [String] -> Doc
parDocW
    [ String
"You should have received a copy of the GNU Affero General Public"
    , String
"License along with this program.  If not, see"
    , String
"<http://www.gnu.org/licenses/>."
    ]
  ]


mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) ()
mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) ()
mainCmdParser CommandDesc ()
helpDesc = do
  String -> CmdParser Identity (IO ()) ()
forall (f :: * -> *) out. String -> CmdParser f out ()
addCmdSynopsis String
"haskell source pretty printer"
  Doc -> CmdParser Identity (IO ()) ()
forall (f :: * -> *) out. Doc -> CmdParser f out ()
addCmdHelp (Doc -> CmdParser Identity (IO ()) ())
-> Doc -> CmdParser Identity (IO ()) ()
forall a b. (a -> b) -> a -> b
$ Doc
helpDoc
  -- addCmd "debugArgs" $ do
  CommandDesc () -> CmdParser Identity (IO ()) ()
forall (f :: * -> *) a.
Applicative f =>
CommandDesc a -> CmdParser f (IO ()) ()
addHelpCommand CommandDesc ()
helpDesc
  String
-> CmdParser Identity (IO ()) () -> CmdParser Identity (IO ()) ()
forall (f :: * -> *) out.
Applicative f =>
String -> CmdParser f out () -> CmdParser f out ()
addCmd String
"license" (CmdParser Identity (IO ()) () -> CmdParser Identity (IO ()) ())
-> CmdParser Identity (IO ()) () -> CmdParser Identity (IO ()) ()
forall a b. (a -> b) -> a -> b
$ IO () -> CmdParser Identity (IO ()) ()
forall out (f :: * -> *). out -> CmdParser f out ()
addCmdImpl (IO () -> CmdParser Identity (IO ()) ())
-> IO () -> CmdParser Identity (IO ()) ()
forall a b. (a -> b) -> a -> b
$ Doc -> IO ()
forall a. Show a => a -> IO ()
print (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc
licenseDoc
  -- addButcherDebugCommand
  CmdParser Identity (IO ()) ()
forall (f :: * -> *) out. CmdParser f out ()
reorderStart
  Bool
printHelp    <- String -> [String] -> Flag Void -> CmdParser Identity (IO ()) Bool
forall (f :: * -> *) out.
Applicative f =>
String -> [String] -> Flag Void -> CmdParser f out Bool
addSimpleBoolFlag String
"h" [String
"help"] Flag Void
forall a. Monoid a => a
mempty
  Bool
printVersion <- String -> [String] -> Flag Void -> CmdParser Identity (IO ()) Bool
forall (f :: * -> *) out.
Applicative f =>
String -> [String] -> Flag Void -> CmdParser f out Bool
addSimpleBoolFlag String
"" [String
"version"] Flag Void
forall a. Monoid a => a
mempty
  Bool
printLicense <- String -> [String] -> Flag Void -> CmdParser Identity (IO ()) Bool
forall (f :: * -> *) out.
Applicative f =>
String -> [String] -> Flag Void -> CmdParser f out Bool
addSimpleBoolFlag String
"" [String
"license"] Flag Void
forall a. Monoid a => a
mempty
  Bool
noUserConfig <- String -> [String] -> Flag Void -> CmdParser Identity (IO ()) Bool
forall (f :: * -> *) out.
Applicative f =>
String -> [String] -> Flag Void -> CmdParser f out Bool
addSimpleBoolFlag String
"" [String
"no-user-config"] Flag Void
forall a. Monoid a => a
mempty
  [String]
configPaths  <- String
-> [String]
-> String
-> Flag Void
-> CmdParser Identity (IO ()) [String]
forall (f :: * -> *) out.
Applicative f =>
String
-> [String] -> String -> Flag Void -> CmdParser f out [String]
addFlagStringParams String
""
                                      [String
"config-file"]
                                      String
"PATH"
                                      (String -> Flag Void
forall p. String -> Flag p
flagHelpStr String
"path to config file") -- TODO: allow default on addFlagStringParam ?
  CConfig Option
cmdlineConfig  <- CmdParser Identity (IO ()) (CConfig Option)
forall out. CmdParser Identity out (CConfig Option)
cmdlineConfigParser
  Bool
suppressOutput <- String -> [String] -> Flag Void -> CmdParser Identity (IO ()) Bool
forall (f :: * -> *) out.
Applicative f =>
String -> [String] -> Flag Void -> CmdParser f out Bool
addSimpleBoolFlag
    String
""
    [String
"suppress-output"]
    (Doc -> Flag Void
forall p. Doc -> Flag p
flagHelp (Doc -> Flag Void) -> Doc -> Flag Void
forall a b. (a -> b) -> a -> b
$ String -> Doc
parDoc
      String
"suppress the regular output, i.e. the transformed haskell source"
    )
  Int
_verbosity <- String -> [String] -> Flag Void -> CmdParser Identity (IO ()) Int
forall (f :: * -> *) out.
Applicative f =>
String -> [String] -> Flag Void -> CmdParser f out Int
addSimpleCountFlag
    String
"v"
    [String
"verbose"]
    (Doc -> Flag Void
forall p. Doc -> Flag p
flagHelp (Doc -> Flag Void) -> Doc -> Flag Void
forall a b. (a -> b) -> a -> b
$ String -> Doc
parDoc String
"[currently without effect; TODO]")
  Bool
checkMode <- String -> [String] -> Flag Void -> CmdParser Identity (IO ()) Bool
forall (f :: * -> *) out.
Applicative f =>
String -> [String] -> Flag Void -> CmdParser f out Bool
addSimpleBoolFlag
    String
"c"
    [String
"check-mode"]
    (Doc -> Flag Void
forall p. Doc -> Flag p
flagHelp
      ([Doc] -> Doc
PP.vcat
        [ String -> Doc
PP.text String
"check for changes but do not write them out"
        , String -> Doc
PP.text String
"exits with code 0 if no changes necessary, 1 otherwise"
        , String -> Doc
PP.text String
"and print file path(s) of files that have changes to stdout"
        ]
      )
    )
  WriteMode
writeMode <- String
-> [String]
-> String
-> Flag WriteMode
-> CmdParser Identity (IO ()) WriteMode
forall (f :: * -> *) p out.
(Applicative f, Typeable p, Read p, Show p) =>
String -> [String] -> String -> Flag p -> CmdParser f out p
addFlagReadParam
    String
""
    [String
"write-mode"]
    String
"(display|inplace)"
    (              Doc -> Flag WriteMode
forall p. Doc -> Flag p
flagHelp
        ([Doc] -> Doc
PP.vcat
          [ String -> Doc
PP.text String
"display: output for any input(s) goes to stdout"
          , String -> Doc
PP.text String
"inplace: override respective input file (without backup!)"
          ]
        )
    Flag WriteMode -> Flag WriteMode -> Flag WriteMode
forall a. Semigroup a => a -> a -> a
Data.Monoid.<> WriteMode -> Flag WriteMode
forall p. p -> Flag p
flagDefault WriteMode
Display
    )
  [String]
inputParams <- String -> Param Void -> CmdParser Identity (IO ()) [String]
forall (f :: * -> *) out.
Applicative f =>
String -> Param Void -> CmdParser f out [String]
addParamNoFlagStrings
    String
"PATH"
    (String -> Param Void
forall p. String -> Param p
paramHelpStr String
"paths to input/inout haskell source files")
  CmdParser Identity (IO ()) ()
forall (f :: * -> *) out. CmdParser f out ()
reorderStop
  IO () -> CmdParser Identity (IO ()) ()
forall out (f :: * -> *). out -> CmdParser f out ()
addCmdImpl (IO () -> CmdParser Identity (IO ()) ())
-> IO () -> CmdParser Identity (IO ()) ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
printLicense (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Doc -> IO ()
forall a. Show a => a -> IO ()
print Doc
licenseDoc
      IO ()
forall a. IO a
System.Exit.exitSuccess
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
printVersion (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      do
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"brittany version " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> String
showVersion Version
version
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Copyright (C) 2016-2019 Lennart Spitzner"
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Copyright (C) 2019 PRODA LTD"
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"There is NO WARRANTY, to the extent permitted by law."
      IO ()
forall a. IO a
System.Exit.exitSuccess
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
printHelp (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
        (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn
        (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Style -> Doc -> String
PP.renderStyle Style
PP.style { ribbonsPerLine :: Float
PP.ribbonsPerLine = Float
1.0 }
        (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ CommandDesc () -> Doc
forall a. CommandDesc a -> Doc
ppHelpShallow CommandDesc ()
helpDesc
      IO ()
forall a. IO a
System.Exit.exitSuccess

    let inputPaths :: [Maybe String]
inputPaths =
          if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
inputParams then [Maybe String
forall a. Maybe a
Nothing] else (String -> Maybe String) -> [String] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map String -> Maybe String
forall a. a -> Maybe a
Just [String]
inputParams
    let outputPaths :: [Maybe String]
outputPaths = case WriteMode
writeMode of
          WriteMode
Display -> Maybe String -> [Maybe String]
forall a. a -> [a]
repeat Maybe String
forall a. Maybe a
Nothing
          WriteMode
Inplace -> [Maybe String]
inputPaths

    [String]
configsToLoad <- IO [String] -> IO [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> IO [String]) -> IO [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
configPaths
      then
        Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList (Maybe String -> [String]) -> IO (Maybe String) -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IO String
Directory.getCurrentDirectory IO String -> (String -> IO (Maybe String)) -> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO (Maybe String)
findLocalConfigPath)
      else [String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String]
configPaths

    Config
config <-
      MaybeT IO Config -> IO (Maybe Config)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT
          (if Bool
noUserConfig
            then CConfig Option -> [String] -> MaybeT IO Config
readConfigs CConfig Option
cmdlineConfig [String]
configsToLoad
            else CConfig Option -> [String] -> MaybeT IO Config
readConfigsWithUserConfig CConfig Option
cmdlineConfig [String]
configsToLoad
          )
        IO (Maybe Config) -> (Maybe Config -> IO Config) -> IO Config
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Maybe Config
Nothing -> ExitCode -> IO Config
forall a. ExitCode -> IO a
System.Exit.exitWith (Int -> ExitCode
System.Exit.ExitFailure Int
53)
              Just Config
x  -> Config -> IO Config
forall (m :: * -> *) a. Monad m => a -> m a
return Config
x
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config
config Config
-> (Config -> CDebugConfig Identity) -> CDebugConfig Identity
forall a b. a -> (a -> b) -> b
& Config -> CDebugConfig Identity
forall (f :: * -> *). CConfig f -> CDebugConfig f
_conf_debug CDebugConfig Identity
-> (CDebugConfig Identity -> Identity (Last Bool))
-> Identity (Last Bool)
forall a b. a -> (a -> b) -> b
& CDebugConfig Identity -> Identity (Last Bool)
forall (f :: * -> *). CDebugConfig f -> f (Last Bool)
_dconf_dump_config Identity (Last Bool) -> (Identity (Last Bool) -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
& Identity (Last Bool) -> Bool
forall a b. Coercible a b => Identity a -> b
confUnpack)
      (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO () -> IO ()
forall a. String -> a -> a
trace (Config -> String
showConfigYaml Config
config)
      (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    [Either Int ChangeStatus]
results <- (Maybe String -> Maybe String -> IO (Either Int ChangeStatus))
-> [Maybe String] -> [Maybe String] -> IO [Either Int ChangeStatus]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM ((String -> IO ())
-> Config
-> Bool
-> Bool
-> Maybe String
-> Maybe String
-> IO (Either Int ChangeStatus)
coreIO String -> IO ()
putStrErrLn Config
config Bool
suppressOutput Bool
checkMode)
                        [Maybe String]
inputPaths
                        [Maybe String]
outputPaths

    if Bool
checkMode
      then Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((ChangeStatus -> Bool) -> [ChangeStatus] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ChangeStatus -> ChangeStatus -> Bool
forall a. Eq a => a -> a -> Bool
== ChangeStatus
Changes) ([Either Int ChangeStatus] -> [ChangeStatus]
forall a b. [Either a b] -> [b]
Data.Either.rights [Either Int ChangeStatus]
results))
        (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO ()
forall a. ExitCode -> IO a
System.Exit.exitWith (Int -> ExitCode
System.Exit.ExitFailure Int
1)
      else case [Either Int ChangeStatus]
results of
        [Either Int ChangeStatus]
xs | (Either Int ChangeStatus -> Bool)
-> [Either Int ChangeStatus] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Either Int ChangeStatus -> Bool
forall a b. Either a b -> Bool
Data.Either.isRight [Either Int ChangeStatus]
xs -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        [Left Int
x] -> ExitCode -> IO ()
forall a. ExitCode -> IO a
System.Exit.exitWith (Int -> ExitCode
System.Exit.ExitFailure Int
x)
        [Either Int ChangeStatus]
_ -> ExitCode -> IO ()
forall a. ExitCode -> IO a
System.Exit.exitWith (Int -> ExitCode
System.Exit.ExitFailure Int
1)


data ChangeStatus = Changes | NoChanges
  deriving (ChangeStatus -> ChangeStatus -> Bool
(ChangeStatus -> ChangeStatus -> Bool)
-> (ChangeStatus -> ChangeStatus -> Bool) -> Eq ChangeStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChangeStatus -> ChangeStatus -> Bool
$c/= :: ChangeStatus -> ChangeStatus -> Bool
== :: ChangeStatus -> ChangeStatus -> Bool
$c== :: ChangeStatus -> ChangeStatus -> Bool
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 :: (String -> IO ())
-> Config
-> Bool
-> Bool
-> Maybe String
-> Maybe String
-> IO (Either Int ChangeStatus)
coreIO String -> IO ()
putErrorLnIO Config
config Bool
suppressOutput Bool
checkMode Maybe String
inputPathM Maybe String
outputPathM =
  ExceptT Int IO ChangeStatus -> IO (Either Int ChangeStatus)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
ExceptT.runExceptT (ExceptT Int IO ChangeStatus -> IO (Either Int ChangeStatus))
-> ExceptT Int IO ChangeStatus -> IO (Either Int ChangeStatus)
forall a b. (a -> b) -> a -> b
$ do
    let putErrorLn :: String -> ExceptT Int IO ()
putErrorLn = IO () -> ExceptT e IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT e IO ())
-> (String -> IO ()) -> String -> ExceptT e IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putErrorLnIO :: String -> ExceptT.ExceptT e IO ()
    let ghcOptions :: [String]
ghcOptions = Config
config Config
-> (Config -> CForwardOptions Identity) -> CForwardOptions Identity
forall a b. a -> (a -> b) -> b
& Config -> CForwardOptions Identity
forall (f :: * -> *). CConfig f -> CForwardOptions f
_conf_forward CForwardOptions Identity
-> (CForwardOptions Identity -> Identity [String])
-> Identity [String]
forall a b. a -> (a -> b) -> b
& CForwardOptions Identity -> Identity [String]
forall (f :: * -> *). CForwardOptions f -> f [String]
_options_ghc Identity [String] -> (Identity [String] -> [String]) -> [String]
forall a b. a -> (a -> b) -> b
& Identity [String] -> [String]
forall a. Identity a -> a
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 :: CPPMode
cppMode    = Config
config Config
-> (Config -> CPreProcessorConfig Identity)
-> CPreProcessorConfig Identity
forall a b. a -> (a -> b) -> b
& Config -> CPreProcessorConfig Identity
forall (f :: * -> *). CConfig f -> CPreProcessorConfig f
_conf_preprocessor CPreProcessorConfig Identity
-> (CPreProcessorConfig Identity -> Identity (Last CPPMode))
-> Identity (Last CPPMode)
forall a b. a -> (a -> b) -> b
& CPreProcessorConfig Identity -> Identity (Last CPPMode)
forall (f :: * -> *). CPreProcessorConfig f -> f (Last CPPMode)
_ppconf_CPPMode Identity (Last CPPMode)
-> (Identity (Last CPPMode) -> CPPMode) -> CPPMode
forall a b. a -> (a -> b) -> b
& Identity (Last CPPMode) -> CPPMode
forall a b. Coercible a b => Identity a -> b
confUnpack
    -- the flag will do the following: insert a marker string
    -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with
    -- "#include" before processing (parsing) input; and remove that marker
    -- string from the transformation output.
    -- The flag is intentionally misspelled to prevent clashing with
    -- inline-config stuff.
    let hackAroundIncludes :: Bool
hackAroundIncludes =
          Config
config Config
-> (Config -> CPreProcessorConfig Identity)
-> CPreProcessorConfig Identity
forall a b. a -> (a -> b) -> b
& Config -> CPreProcessorConfig Identity
forall (f :: * -> *). CConfig f -> CPreProcessorConfig f
_conf_preprocessor CPreProcessorConfig Identity
-> (CPreProcessorConfig Identity -> Identity (Last Bool))
-> Identity (Last Bool)
forall a b. a -> (a -> b) -> b
& CPreProcessorConfig Identity -> Identity (Last Bool)
forall (f :: * -> *). CPreProcessorConfig f -> f (Last Bool)
_ppconf_hackAroundIncludes Identity (Last Bool) -> (Identity (Last Bool) -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
& Identity (Last Bool) -> Bool
forall a b. Coercible a b => Identity a -> b
confUnpack
    let exactprintOnly :: Bool
exactprintOnly = Bool
viaGlobal Bool -> Bool -> Bool
|| Bool
viaDebug
         where
          viaGlobal :: Bool
viaGlobal = Config
config Config -> (Config -> Identity (Last Bool)) -> Identity (Last Bool)
forall a b. a -> (a -> b) -> b
& Config -> Identity (Last Bool)
forall (f :: * -> *). CConfig f -> f (Last Bool)
_conf_roundtrip_exactprint_only Identity (Last Bool) -> (Identity (Last Bool) -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
& Identity (Last Bool) -> Bool
forall a b. Coercible a b => Identity a -> b
confUnpack
          viaDebug :: Bool
viaDebug =
            Config
config Config
-> (Config -> CDebugConfig Identity) -> CDebugConfig Identity
forall a b. a -> (a -> b) -> b
& Config -> CDebugConfig Identity
forall (f :: * -> *). CConfig f -> CDebugConfig f
_conf_debug CDebugConfig Identity
-> (CDebugConfig Identity -> Identity (Last Bool))
-> Identity (Last Bool)
forall a b. a -> (a -> b) -> b
& CDebugConfig Identity -> Identity (Last Bool)
forall (f :: * -> *). CDebugConfig f -> f (Last Bool)
_dconf_roundtrip_exactprint_only Identity (Last Bool) -> (Identity (Last Bool) -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
& Identity (Last Bool) -> Bool
forall a b. Coercible a b => Identity a -> b
confUnpack

    let cppCheckFunc :: DynFlags -> IO (Either String Bool)
cppCheckFunc DynFlags
dynFlags = if Extension -> DynFlags -> Bool
GHC.xopt Extension
GHC.Cpp DynFlags
dynFlags
          then case CPPMode
cppMode of
            CPPMode
CPPModeAbort -> do
              Either String Bool -> IO (Either String Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Bool -> IO (Either String Bool))
-> Either String Bool -> IO (Either String Bool)
forall a b. (a -> b) -> a -> b
$ String -> Either String Bool
forall a b. a -> Either a b
Left String
"Encountered -XCPP. Aborting."
            CPPMode
CPPModeWarn -> do
              String -> IO ()
putErrorLnIO
                (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$  String
"Warning: Encountered -XCPP."
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" Be warned that -XCPP is not supported and that"
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" brittany cannot check that its output is syntactically"
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" valid in its presence."
              Either String Bool -> IO (Either String Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Bool -> IO (Either String Bool))
-> Either String Bool -> IO (Either String Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Either String Bool
forall a b. b -> Either a b
Right Bool
True
            CPPMode
CPPModeNowarn -> Either String Bool -> IO (Either String Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Bool -> IO (Either String Bool))
-> Either String Bool -> IO (Either String Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Either String Bool
forall a b. b -> Either a b
Right Bool
True
          else Either String Bool -> IO (Either String Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Bool -> IO (Either String Bool))
-> Either String Bool -> IO (Either String Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Either String Bool
forall a b. b -> Either a b
Right Bool
False
    (Either String (Anns, ParsedSource, Bool)
parseResult, Text
originalContents) <- case Maybe String
inputPathM of
      Maybe String
Nothing -> do
        -- TODO: refactor this hack to not be mixed into parsing logic
        let hackF :: ShowS
hackF String
s = if String
"#include" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s
              then String
"-- BRITANY_INCLUDE_HACK " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
              else String
s
        let hackTransform :: ShowS
hackTransform = if Bool
hackAroundIncludes Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
exactprintOnly
              then String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n" ([String] -> String) -> (String -> [String]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShowS
hackF ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines'
              else ShowS
forall a. a -> a
id
        String
inputString <- IO String -> ExceptT Int IO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ExceptT Int IO String)
-> IO String -> ExceptT Int IO String
forall a b. (a -> b) -> a -> b
$ Handle -> IO String
System.IO.hGetContents Handle
System.IO.stdin
        Either String (Anns, ParsedSource, Bool)
parseRes <- IO (Either String (Anns, ParsedSource, Bool))
-> ExceptT Int IO (Either String (Anns, ParsedSource, Bool))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String (Anns, ParsedSource, Bool))
 -> ExceptT Int IO (Either String (Anns, ParsedSource, Bool)))
-> IO (Either String (Anns, ParsedSource, Bool))
-> ExceptT Int IO (Either String (Anns, ParsedSource, Bool))
forall a b. (a -> b) -> a -> b
$ [String]
-> String
-> (DynFlags -> IO (Either String Bool))
-> String
-> IO (Either String (Anns, ParsedSource, Bool))
forall a.
[String]
-> String
-> (DynFlags -> IO (Either String a))
-> String
-> IO (Either String (Anns, ParsedSource, a))
parseModuleFromString [String]
ghcOptions
                                                   String
"stdin"
                                                   DynFlags -> IO (Either String Bool)
cppCheckFunc
                                                   (ShowS
hackTransform String
inputString)
        (Either String (Anns, ParsedSource, Bool), Text)
-> ExceptT Int IO (Either String (Anns, ParsedSource, Bool), Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (Anns, ParsedSource, Bool)
parseRes, String -> Text
Text.pack String
inputString)
      Just String
p -> IO (Either String (Anns, ParsedSource, Bool), Text)
-> ExceptT Int IO (Either String (Anns, ParsedSource, Bool), Text)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String (Anns, ParsedSource, Bool), Text)
 -> ExceptT Int IO (Either String (Anns, ParsedSource, Bool), Text))
-> IO (Either String (Anns, ParsedSource, Bool), Text)
-> ExceptT Int IO (Either String (Anns, ParsedSource, Bool), Text)
forall a b. (a -> b) -> a -> b
$ do
        Either String (Anns, ParsedSource, Bool)
parseRes  <- [String]
-> String
-> (DynFlags -> IO (Either String Bool))
-> IO (Either String (Anns, ParsedSource, Bool))
forall a.
[String]
-> String
-> (DynFlags -> IO (Either String a))
-> IO (Either String (Anns, ParsedSource, a))
parseModule [String]
ghcOptions String
p DynFlags -> IO (Either String Bool)
cppCheckFunc
        Text
inputText <- String -> IO Text
Text.IO.readFile String
p
        -- The above means we read the file twice, but the
        -- GHC API does not really expose the source it
        -- read. Should be in cache still anyways.
        --
        -- We do not use TextL.IO.readFile because lazy IO is evil.
        -- (not identical -> read is not finished ->
        -- handle still open -> write below crashes - evil.)
        (Either String (Anns, ParsedSource, Bool), Text)
-> IO (Either String (Anns, ParsedSource, Bool), Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (Anns, ParsedSource, Bool)
parseRes, Text
inputText)
    case Either String (Anns, ParsedSource, Bool)
parseResult of
      Left String
left -> do
        String -> ExceptT Int IO ()
putErrorLn String
"parse error:"
        String -> ExceptT Int IO ()
putErrorLn String
left
        Int -> ExceptT Int IO ChangeStatus
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
ExceptT.throwE Int
60
      Right (Anns
anns, ParsedSource
parsedSource, Bool
hasCPP) -> do
        (CConfig Option
inlineConf, PerItemConfig
perItemConf) <-
          case
            Anns
-> TopLevelDeclNameMap
-> Either (String, String) (CConfig Option, PerItemConfig)
extractCommentConfigs Anns
anns (ParsedSource -> TopLevelDeclNameMap
getTopLevelDeclNameMap ParsedSource
parsedSource)
          of
            Left (String
err, String
input) -> do
              String -> ExceptT Int IO ()
putErrorLn (String -> ExceptT Int IO ()) -> String -> ExceptT Int IO ()
forall a b. (a -> b) -> a -> b
$ String
"Error: parse error in inline configuration:"
              String -> ExceptT Int IO ()
putErrorLn String
err
              String -> ExceptT Int IO ()
putErrorLn (String -> ExceptT Int IO ()) -> String -> ExceptT Int IO ()
forall a b. (a -> b) -> a -> b
$ String
"  in the string \"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
input String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\"."
              Int -> ExceptT Int IO (CConfig Option, PerItemConfig)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
ExceptT.throwE Int
61
            Right (CConfig Option, PerItemConfig)
c -> -- trace (showTree c) $
              (CConfig Option, PerItemConfig)
-> ExceptT Int IO (CConfig Option, PerItemConfig)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CConfig Option, PerItemConfig)
c
        let moduleConf :: Config
moduleConf = (forall a. Identity a -> Option a -> Identity a)
-> Config -> CConfig Option -> Config
forall (k :: (* -> *) -> *) (g :: * -> *) (h :: * -> *)
       (i :: * -> *).
CZipWith k =>
(forall a. g a -> h a -> i a) -> k g -> k h -> k i
cZipWith forall a. Identity a -> Option a -> Identity a
fromOptionIdentity Config
config CConfig Option
inlineConf
        Bool -> ExceptT Int IO () -> ExceptT Int IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config
config Config
-> (Config -> CDebugConfig Identity) -> CDebugConfig Identity
forall a b. a -> (a -> b) -> b
& Config -> CDebugConfig Identity
forall (f :: * -> *). CConfig f -> CDebugConfig f
_conf_debug CDebugConfig Identity
-> (CDebugConfig Identity -> Identity (Last Bool))
-> Identity (Last Bool)
forall a b. a -> (a -> b) -> b
& CDebugConfig Identity -> Identity (Last Bool)
forall (f :: * -> *). CDebugConfig f -> f (Last Bool)
_dconf_dump_ast_full Identity (Last Bool) -> (Identity (Last Bool) -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
& Identity (Last Bool) -> Bool
forall a b. Coercible a b => Identity a -> b
confUnpack) (ExceptT Int IO () -> ExceptT Int IO ())
-> ExceptT Int IO () -> ExceptT Int IO ()
forall a b. (a -> b) -> a -> b
$ do
          let val :: Doc
val = Int -> LayouterF -> ParsedSource -> Doc
forall a. Data a => Int -> LayouterF -> a -> Doc
printTreeWithCustom Int
100 (Anns -> LayouterF
customLayouterF Anns
anns) ParsedSource
parsedSource
          String -> ExceptT Int IO () -> ExceptT Int IO ()
forall a. String -> a -> a
trace (String
"---- ast ----\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show Doc
val) (ExceptT Int IO () -> ExceptT Int IO ())
-> ExceptT Int IO () -> ExceptT Int IO ()
forall a b. (a -> b) -> a -> b
$ () -> ExceptT Int IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        let disableFormatting :: Bool
disableFormatting =
              Config
moduleConf Config -> (Config -> Identity (Last Bool)) -> Identity (Last Bool)
forall a b. a -> (a -> b) -> b
& Config -> Identity (Last Bool)
forall (f :: * -> *). CConfig f -> f (Last Bool)
_conf_disable_formatting Identity (Last Bool) -> (Identity (Last Bool) -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
& Identity (Last Bool) -> Bool
forall a b. Coercible a b => Identity a -> b
confUnpack
        ([BrittanyError]
errsWarns, Text
outSText, Bool
hasChanges) <- do
          if
            | Bool
disableFormatting -> do
              ([BrittanyError], Text, Bool)
-> ExceptT Int IO ([BrittanyError], Text, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Text
originalContents, Bool
False)
            | Bool
exactprintOnly -> do
              let r :: Text
r = String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ParsedSource -> Anns -> String
forall ast. Annotate ast => Located ast -> Anns -> String
ExactPrint.exactPrint ParsedSource
parsedSource Anns
anns
              ([BrittanyError], Text, Bool)
-> ExceptT Int IO ([BrittanyError], Text, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Text
r, Text
r Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
originalContents)
            | Bool
otherwise -> do
              let omitCheck :: Bool
omitCheck =
                    Config
moduleConf
                      Config -> (Config -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
&  Config -> CErrorHandlingConfig Identity
forall (f :: * -> *). CConfig f -> CErrorHandlingConfig f
_conf_errorHandling
                      (Config -> CErrorHandlingConfig Identity)
-> (CErrorHandlingConfig Identity -> Identity (Last Bool))
-> Config
-> Identity (Last Bool)
forall a b c. (a -> b) -> (b -> c) -> a -> c
.> CErrorHandlingConfig Identity -> Identity (Last Bool)
forall (f :: * -> *). CErrorHandlingConfig f -> f (Last Bool)
_econf_omit_output_valid_check
                      (Config -> Identity (Last Bool))
-> (Identity (Last Bool) -> Bool) -> Config -> Bool
forall a b c. (a -> b) -> (b -> c) -> a -> c
.> Identity (Last Bool) -> Bool
forall a b. Coercible a b => Identity a -> b
confUnpack
              ([BrittanyError]
ews, Text
outRaw) <- if Bool
hasCPP Bool -> Bool -> Bool
|| Bool
omitCheck
                then ([BrittanyError], Text) -> ExceptT Int IO ([BrittanyError], Text)
forall (m :: * -> *) a. Monad m => a -> m a
return
                  (([BrittanyError], Text) -> ExceptT Int IO ([BrittanyError], Text))
-> ([BrittanyError], Text)
-> ExceptT Int IO ([BrittanyError], Text)
forall a b. (a -> b) -> a -> b
$ Config
-> PerItemConfig -> Anns -> ParsedSource -> ([BrittanyError], Text)
pPrintModule Config
moduleConf PerItemConfig
perItemConf Anns
anns ParsedSource
parsedSource
                else IO ([BrittanyError], Text)
-> ExceptT Int IO ([BrittanyError], Text)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([BrittanyError], Text)
 -> ExceptT Int IO ([BrittanyError], Text))
-> IO ([BrittanyError], Text)
-> ExceptT Int IO ([BrittanyError], Text)
forall a b. (a -> b) -> a -> b
$ Config
-> PerItemConfig
-> Anns
-> ParsedSource
-> IO ([BrittanyError], Text)
pPrintModuleAndCheck Config
moduleConf
                                                   PerItemConfig
perItemConf
                                                   Anns
anns
                                                   ParsedSource
parsedSource
              let hackF :: Text -> Text
hackF Text
s = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
s (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
TextL.stripPrefix
                    (String -> Text
TextL.pack String
"-- BRITANY_INCLUDE_HACK ")
                    Text
s
              let out :: Text
out = Text -> Text
TextL.toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ if Bool
hackAroundIncludes
                    then
                      Text -> [Text] -> Text
TextL.intercalate (String -> Text
TextL.pack String
"\n")
                      ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
hackF
                      ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
TextL.splitOn (String -> Text
TextL.pack String
"\n") Text
outRaw
                    else Text
outRaw
              Text
out' <- if Config
moduleConf Config -> (Config -> Identity (Last Bool)) -> Identity (Last Bool)
forall a b. a -> (a -> b) -> b
& Config -> Identity (Last Bool)
forall (f :: * -> *). CConfig f -> f (Last Bool)
_conf_obfuscate Identity (Last Bool) -> (Identity (Last Bool) -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
& Identity (Last Bool) -> Bool
forall a b. Coercible a b => Identity a -> b
confUnpack
                then IO Text -> ExceptT Int IO Text
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Text -> ExceptT Int IO Text) -> IO Text -> ExceptT Int IO Text
forall a b. (a -> b) -> a -> b
$ Text -> IO Text
obfuscate Text
out
                else Text -> ExceptT Int IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
out
              ([BrittanyError], Text, Bool)
-> ExceptT Int IO ([BrittanyError], Text, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([BrittanyError], Text, Bool)
 -> ExceptT Int IO ([BrittanyError], Text, Bool))
-> ([BrittanyError], Text, Bool)
-> ExceptT Int IO ([BrittanyError], Text, Bool)
forall a b. (a -> b) -> a -> b
$ ([BrittanyError]
ews, Text
out', Text
out' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
originalContents)
        let customErrOrder :: BrittanyError -> Int
customErrOrder ErrorInput{}         = Int
4
            customErrOrder LayoutWarning{}      = -Int
1 :: Int
            customErrOrder ErrorOutputCheck{}   = Int
1
            customErrOrder ErrorUnusedComment{} = Int
2
            customErrOrder ErrorUnknownNode{}   = -Int
2 :: Int
            customErrOrder ErrorMacroConfig{}   = Int
5
        Bool -> ExceptT Int IO () -> ExceptT Int IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [BrittanyError] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BrittanyError]
errsWarns) (ExceptT Int IO () -> ExceptT Int IO ())
-> ExceptT Int IO () -> ExceptT Int IO ()
forall a b. (a -> b) -> a -> b
$ do
          let groupedErrsWarns :: [[BrittanyError]]
groupedErrsWarns =
                (BrittanyError -> Int) -> [BrittanyError] -> [[BrittanyError]]
forall b a. Eq b => (a -> b) -> [a] -> [[a]]
Data.List.Extra.groupOn BrittanyError -> Int
customErrOrder
                  ([BrittanyError] -> [[BrittanyError]])
-> [BrittanyError] -> [[BrittanyError]]
forall a b. (a -> b) -> a -> b
$ (BrittanyError -> Int) -> [BrittanyError] -> [BrittanyError]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn BrittanyError -> Int
customErrOrder
                  ([BrittanyError] -> [BrittanyError])
-> [BrittanyError] -> [BrittanyError]
forall a b. (a -> b) -> a -> b
$ [BrittanyError]
errsWarns
          [[BrittanyError]]
groupedErrsWarns [[BrittanyError]]
-> ([BrittanyError] -> ExceptT Int IO ()) -> ExceptT Int IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
`forM_` \case
            (ErrorOutputCheck{} : [BrittanyError]
_) -> do
              String -> ExceptT Int IO ()
putErrorLn
                (String -> ExceptT Int IO ()) -> String -> ExceptT Int IO ()
forall a b. (a -> b) -> a -> b
$  String
"ERROR: brittany pretty printer"
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" returned syntactically invalid result."
            (ErrorInput String
str : [BrittanyError]
_) -> do
              String -> ExceptT Int IO ()
putErrorLn (String -> ExceptT Int IO ()) -> String -> ExceptT Int IO ()
forall a b. (a -> b) -> a -> b
$ String
"ERROR: parse error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str
            uns :: [BrittanyError]
uns@(ErrorUnknownNode{} : [BrittanyError]
_) -> do
              String -> ExceptT Int IO ()
putErrorLn
                (String -> ExceptT Int IO ()) -> String -> ExceptT Int IO ()
forall a b. (a -> b) -> a -> b
$ String
"WARNING: encountered unknown syntactical constructs:"
              [BrittanyError]
uns [BrittanyError]
-> (BrittanyError -> ExceptT Int IO ()) -> ExceptT Int IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
`forM_` \case
                ErrorUnknownNode String
str ast :: GenLocated SrcSpan ast
ast@(L SrcSpan
loc ast
_) -> do
                  String -> ExceptT Int IO ()
putErrorLn (String -> ExceptT Int IO ()) -> String -> ExceptT Int IO ()
forall a b. (a -> b) -> a -> b
$ String
"  " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
str String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" at " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SDoc -> String
showSDocUnsafe (SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
loc)
                  Bool -> ExceptT Int IO () -> ExceptT Int IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
                      ( Config
config
                      Config
-> (Config -> CDebugConfig Identity) -> CDebugConfig Identity
forall a b. a -> (a -> b) -> b
& Config -> CDebugConfig Identity
forall (f :: * -> *). CConfig f -> CDebugConfig f
_conf_debug
                      CDebugConfig Identity
-> (CDebugConfig Identity -> Identity (Last Bool))
-> Identity (Last Bool)
forall a b. a -> (a -> b) -> b
& CDebugConfig Identity -> Identity (Last Bool)
forall (f :: * -> *). CDebugConfig f -> f (Last Bool)
_dconf_dump_ast_unknown
                      Identity (Last Bool) -> (Identity (Last Bool) -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
& Identity (Last Bool) -> Bool
forall a b. Coercible a b => Identity a -> b
confUnpack
                      )
                    (ExceptT Int IO () -> ExceptT Int IO ())
-> ExceptT Int IO () -> ExceptT Int IO ()
forall a b. (a -> b) -> a -> b
$ do
                        String -> ExceptT Int IO ()
putErrorLn (String -> ExceptT Int IO ()) -> String -> ExceptT Int IO ()
forall a b. (a -> b) -> a -> b
$ String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show (GenLocated SrcSpan ast -> Doc
forall ast. Data ast => ast -> Doc
astToDoc GenLocated SrcSpan ast
ast)
                BrittanyError
_ -> String -> ExceptT Int IO ()
forall a. HasCallStack => String -> a
error String
"cannot happen (TM)"
              String -> ExceptT Int IO ()
putErrorLn
                String
"  -> falling back on exactprint for this element of the module"
            warns :: [BrittanyError]
warns@(LayoutWarning{} : [BrittanyError]
_) -> do
              String -> ExceptT Int IO ()
putErrorLn (String -> ExceptT Int IO ()) -> String -> ExceptT Int IO ()
forall a b. (a -> b) -> a -> b
$ String
"WARNINGS:"
              [BrittanyError]
warns [BrittanyError]
-> (BrittanyError -> ExceptT Int IO ()) -> ExceptT Int IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
`forM_` \case
                LayoutWarning String
str -> String -> ExceptT Int IO ()
putErrorLn String
str
                BrittanyError
_                 -> String -> ExceptT Int IO ()
forall a. HasCallStack => String -> a
error String
"cannot happen (TM)"
            unused :: [BrittanyError]
unused@(ErrorUnusedComment{} : [BrittanyError]
_) -> do
              String -> ExceptT Int IO ()
putErrorLn
                (String -> ExceptT Int IO ()) -> String -> ExceptT Int IO ()
forall a b. (a -> b) -> a -> b
$  String
"Error: detected unprocessed comments."
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" The transformation output will most likely"
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" not contain some of the comments"
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" present in the input haskell source file."
              String -> ExceptT Int IO ()
putErrorLn (String -> ExceptT Int IO ()) -> String -> ExceptT Int IO ()
forall a b. (a -> b) -> a -> b
$ String
"Affected are the following comments:"
              [BrittanyError]
unused [BrittanyError]
-> (BrittanyError -> ExceptT Int IO ()) -> ExceptT Int IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
`forM_` \case
                ErrorUnusedComment String
str -> String -> ExceptT Int IO ()
putErrorLn String
str
                BrittanyError
_                      -> String -> ExceptT Int IO ()
forall a. HasCallStack => String -> a
error String
"cannot happen (TM)"
            (ErrorMacroConfig String
err String
input : [BrittanyError]
_) -> do
              String -> ExceptT Int IO ()
putErrorLn (String -> ExceptT Int IO ()) -> String -> ExceptT Int IO ()
forall a b. (a -> b) -> a -> b
$ String
"Error: parse error in inline configuration:"
              String -> ExceptT Int IO ()
putErrorLn String
err
              String -> ExceptT Int IO ()
putErrorLn (String -> ExceptT Int IO ()) -> String -> ExceptT Int IO ()
forall a b. (a -> b) -> a -> b
$ String
"  in the string \"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
input String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\"."
            [] -> String -> ExceptT Int IO ()
forall a. HasCallStack => String -> a
error String
"cannot happen"
        -- TODO: don't output anything when there are errors unless user
        -- adds some override?
        let
          hasErrors :: Bool
hasErrors =
            case Config
config Config
-> (Config -> CErrorHandlingConfig Identity)
-> CErrorHandlingConfig Identity
forall a b. a -> (a -> b) -> b
& Config -> CErrorHandlingConfig Identity
forall (f :: * -> *). CConfig f -> CErrorHandlingConfig f
_conf_errorHandling CErrorHandlingConfig Identity
-> (CErrorHandlingConfig Identity -> Identity (Last Bool))
-> Identity (Last Bool)
forall a b. a -> (a -> b) -> b
& CErrorHandlingConfig Identity -> Identity (Last Bool)
forall (f :: * -> *). CErrorHandlingConfig f -> f (Last Bool)
_econf_Werror Identity (Last Bool) -> (Identity (Last Bool) -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
& Identity (Last Bool) -> Bool
forall a b. Coercible a b => Identity a -> b
confUnpack of
              Bool
False -> Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (-Int
1 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: (BrittanyError -> Int) -> [BrittanyError] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BrittanyError -> Int
customErrOrder [BrittanyError]
errsWarns)
              Bool
True  -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [BrittanyError] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BrittanyError]
errsWarns
          outputOnErrs :: Bool
outputOnErrs =
            Config
config
              Config
-> (Config -> CErrorHandlingConfig Identity)
-> CErrorHandlingConfig Identity
forall a b. a -> (a -> b) -> b
& Config -> CErrorHandlingConfig Identity
forall (f :: * -> *). CConfig f -> CErrorHandlingConfig f
_conf_errorHandling
              CErrorHandlingConfig Identity
-> (CErrorHandlingConfig Identity -> Identity (Last Bool))
-> Identity (Last Bool)
forall a b. a -> (a -> b) -> b
& CErrorHandlingConfig Identity -> Identity (Last Bool)
forall (f :: * -> *). CErrorHandlingConfig f -> f (Last Bool)
_econf_produceOutputOnErrors
              Identity (Last Bool) -> (Identity (Last Bool) -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
& Identity (Last Bool) -> Bool
forall a b. Coercible a b => Identity a -> b
confUnpack
          shouldOutput :: Bool
shouldOutput =
            Bool -> Bool
not Bool
suppressOutput
              Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
checkMode
              Bool -> Bool -> Bool
&& (Bool -> Bool
not Bool
hasErrors Bool -> Bool -> Bool
|| Bool
outputOnErrs)

        Bool -> ExceptT Int IO () -> ExceptT Int IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldOutput
          (ExceptT Int IO () -> ExceptT Int IO ())
-> ExceptT Int IO () -> ExceptT Int IO ()
forall a b. (a -> b) -> a -> b
$ CDebugConfig Identity -> ExceptT Int IO () -> ExceptT Int IO ()
forall a. CDebugConfig Identity -> a -> a
addTraceSep (Config -> CDebugConfig Identity
forall (f :: * -> *). CConfig f -> CDebugConfig f
_conf_debug Config
config)
          (ExceptT Int IO () -> ExceptT Int IO ())
-> ExceptT Int IO () -> ExceptT Int IO ()
forall a b. (a -> b) -> a -> b
$ case Maybe String
outputPathM of
              Maybe String
Nothing -> IO () -> ExceptT Int IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Int IO ()) -> IO () -> ExceptT Int IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
Text.IO.putStr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
outSText
              Just String
p  -> IO () -> ExceptT Int IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Int IO ()) -> IO () -> ExceptT Int IO ()
forall a b. (a -> b) -> a -> b
$ do
                let isIdentical :: Bool
isIdentical = case Maybe String
inputPathM of
                      Maybe String
Nothing -> Bool
False
                      Just String
_  -> Bool -> Bool
not Bool
hasChanges
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isIdentical (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
Text.IO.writeFile String
p (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
outSText

        Bool -> ExceptT Int IO () -> ExceptT Int IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
checkMode Bool -> Bool -> Bool
&& Bool
hasChanges) (ExceptT Int IO () -> ExceptT Int IO ())
-> ExceptT Int IO () -> ExceptT Int IO ()
forall a b. (a -> b) -> a -> b
$ case Maybe String
inputPathM of
          Maybe String
Nothing -> () -> ExceptT Int IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Just String
p -> IO () -> ExceptT Int IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Int IO ()) -> IO () -> ExceptT Int IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"formatting would modify: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
p

        Bool -> ExceptT Int IO () -> ExceptT Int IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hasErrors (ExceptT Int IO () -> ExceptT Int IO ())
-> ExceptT Int IO () -> ExceptT Int IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ExceptT Int IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
ExceptT.throwE Int
70
        ChangeStatus -> ExceptT Int IO ChangeStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
hasChanges then ChangeStatus
Changes else ChangeStatus
NoChanges)
 where
  addTraceSep :: CDebugConfig Identity -> a -> a
addTraceSep CDebugConfig Identity
conf =
    if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
         [ Identity (Last Bool) -> Bool
forall a b. Coercible a b => Identity a -> b
confUnpack (Identity (Last Bool) -> Bool) -> Identity (Last Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ CDebugConfig Identity -> Identity (Last Bool)
forall (f :: * -> *). CDebugConfig f -> f (Last Bool)
_dconf_dump_annotations CDebugConfig Identity
conf
         , Identity (Last Bool) -> Bool
forall a b. Coercible a b => Identity a -> b
confUnpack (Identity (Last Bool) -> Bool) -> Identity (Last Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ CDebugConfig Identity -> Identity (Last Bool)
forall (f :: * -> *). CDebugConfig f -> f (Last Bool)
_dconf_dump_ast_unknown CDebugConfig Identity
conf
         , Identity (Last Bool) -> Bool
forall a b. Coercible a b => Identity a -> b
confUnpack (Identity (Last Bool) -> Bool) -> Identity (Last Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ CDebugConfig Identity -> Identity (Last Bool)
forall (f :: * -> *). CDebugConfig f -> f (Last Bool)
_dconf_dump_ast_full CDebugConfig Identity
conf
         , Identity (Last Bool) -> Bool
forall a b. Coercible a b => Identity a -> b
confUnpack (Identity (Last Bool) -> Bool) -> Identity (Last Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ CDebugConfig Identity -> Identity (Last Bool)
forall (f :: * -> *). CDebugConfig f -> f (Last Bool)
_dconf_dump_bridoc_raw CDebugConfig Identity
conf
         , Identity (Last Bool) -> Bool
forall a b. Coercible a b => Identity a -> b
confUnpack (Identity (Last Bool) -> Bool) -> Identity (Last Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ CDebugConfig Identity -> Identity (Last Bool)
forall (f :: * -> *). CDebugConfig f -> f (Last Bool)
_dconf_dump_bridoc_simpl_alt CDebugConfig Identity
conf
         , Identity (Last Bool) -> Bool
forall a b. Coercible a b => Identity a -> b
confUnpack (Identity (Last Bool) -> Bool) -> Identity (Last Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ CDebugConfig Identity -> Identity (Last Bool)
forall (f :: * -> *). CDebugConfig f -> f (Last Bool)
_dconf_dump_bridoc_simpl_floating CDebugConfig Identity
conf
         , Identity (Last Bool) -> Bool
forall a b. Coercible a b => Identity a -> b
confUnpack (Identity (Last Bool) -> Bool) -> Identity (Last Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ CDebugConfig Identity -> Identity (Last Bool)
forall (f :: * -> *). CDebugConfig f -> f (Last Bool)
_dconf_dump_bridoc_simpl_columns CDebugConfig Identity
conf
         , Identity (Last Bool) -> Bool
forall a b. Coercible a b => Identity a -> b
confUnpack (Identity (Last Bool) -> Bool) -> Identity (Last Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ CDebugConfig Identity -> Identity (Last Bool)
forall (f :: * -> *). CDebugConfig f -> f (Last Bool)
_dconf_dump_bridoc_simpl_indent CDebugConfig Identity
conf
         , Identity (Last Bool) -> Bool
forall a b. Coercible a b => Identity a -> b
confUnpack (Identity (Last Bool) -> Bool) -> Identity (Last Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ CDebugConfig Identity -> Identity (Last Bool)
forall (f :: * -> *). CDebugConfig f -> f (Last Bool)
_dconf_dump_bridoc_final CDebugConfig Identity
conf
         ]
      then String -> a -> a
forall a. String -> a -> a
trace String
"----"
      else a -> a
forall a. a -> a
id