Refactor/Auto-format Main, Brittany.Internal
parent
57c48f64c1
commit
6725d0e119
|
|
@ -6,22 +6,24 @@ module Main where
|
|||
|
||||
#include "prelude.inc"
|
||||
|
||||
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
|
||||
-- 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.Map as Map
|
||||
import qualified Data.Monoid
|
||||
|
||||
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 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 Control.Monad ( zipWithM )
|
||||
import Data.CZipWith
|
||||
|
||||
import qualified Debug.Trace as Trace
|
||||
import qualified Debug.Trace as Trace
|
||||
|
||||
import Language.Haskell.Brittany.Internal.Types
|
||||
import Language.Haskell.Brittany.Internal
|
||||
|
|
@ -30,19 +32,20 @@ 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 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 System.Directory as Directory
|
||||
import qualified System.FilePath.Posix as FilePath
|
||||
|
||||
import qualified DynFlags as GHC
|
||||
import qualified GHC.LanguageExtensions.Type as GHC
|
||||
import qualified DynFlags as GHC
|
||||
import qualified GHC.LanguageExtensions.Type as GHC
|
||||
|
||||
import Paths_brittany
|
||||
|
||||
import Paths_brittany
|
||||
|
||||
|
||||
data WriteMode = Display | Inplace
|
||||
|
|
@ -73,16 +76,16 @@ helpDoc = PP.vcat $ List.intersperse
|
|||
]
|
||||
, 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.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"
|
||||
]
|
||||
[ 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."
|
||||
|
|
@ -93,9 +96,14 @@ helpDoc = PP.vcat $ List.intersperse
|
|||
, "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."]
|
||||
, 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"
|
||||
, parDoc
|
||||
$ "Please report bugs at"
|
||||
++ " https://github.com/lspitzner/brittany/issues"
|
||||
]
|
||||
|
||||
licenseDoc :: PP.Doc
|
||||
|
|
@ -130,29 +138,39 @@ mainCmdParser helpDesc = do
|
|||
addCmd "license" $ addCmdImpl $ print $ licenseDoc
|
||||
-- addButcherDebugCommand
|
||||
reorderStart
|
||||
printHelp <- addSimpleBoolFlag "h" ["help"] mempty
|
||||
printVersion <- addSimpleBoolFlag "" ["version"] mempty
|
||||
printLicense <- addSimpleBoolFlag "" ["license"] mempty
|
||||
configPaths <- addFlagStringParams "" ["config-file"] "PATH" (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ?
|
||||
printHelp <- addSimpleBoolFlag "h" ["help"] mempty
|
||||
printVersion <- addSimpleBoolFlag "" ["version"] mempty
|
||||
printLicense <- addSimpleBoolFlag "" ["license"] 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]")
|
||||
writeMode <- addFlagReadParam
|
||||
(flagHelp $ parDoc
|
||||
"suppress the regular output, i.e. the transformed haskell source"
|
||||
)
|
||||
_verbosity <- addSimpleCountFlag
|
||||
"v"
|
||||
["verbose"]
|
||||
(flagHelp $ parDoc "[currently without effect; TODO]")
|
||||
writeMode <- addFlagReadParam
|
||||
""
|
||||
["write-mode"]
|
||||
"(display|inplace)"
|
||||
( flagHelp
|
||||
( PP.vcat
|
||||
( 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")
|
||||
inputParams <- addParamNoFlagStrings
|
||||
"PATH"
|
||||
(paramHelpStr "paths to input/inout haskell source files")
|
||||
reorderStop
|
||||
addCmdImpl $ void $ do
|
||||
when printLicense $ do
|
||||
|
|
@ -165,29 +183,39 @@ mainCmdParser helpDesc = do
|
|||
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
|
||||
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 inputPaths =
|
||||
if null inputParams then [Nothing] else map Just inputParams
|
||||
let outputPaths = case writeMode of
|
||||
Display -> repeat Nothing
|
||||
Inplace -> inputPaths
|
||||
Display -> repeat Nothing
|
||||
Inplace -> inputPaths
|
||||
|
||||
configsToLoad <- liftIO $ if null configPaths
|
||||
then maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath)
|
||||
else pure configPaths
|
||||
then
|
||||
maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath)
|
||||
else pure configPaths
|
||||
|
||||
config <- runMaybeT (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 ()
|
||||
config <-
|
||||
runMaybeT (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) inputPaths outputPaths
|
||||
results <- zipWithM (coreIO putStrErrLn config suppressOutput)
|
||||
inputPaths
|
||||
outputPaths
|
||||
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)
|
||||
_ -> System.Exit.exitWith (System.Exit.ExitFailure 1)
|
||||
|
||||
|
||||
-- | The main IO parts for the default mode of operation, and after commandline
|
||||
|
|
@ -202,25 +230,32 @@ coreIO
|
|||
-> 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 = ExceptT.runExceptT $ do
|
||||
let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT 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
|
||||
-- ("-- 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 = config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack
|
||||
let exactprintOnly = (config & _conf_roundtrip_exactprint_only & confUnpack)
|
||||
|| (config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack)
|
||||
let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
|
||||
coreIO putErrorLnIO config suppressOutput inputPathM outputPathM =
|
||||
ExceptT.runExceptT $ do
|
||||
let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT 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
|
||||
-- ("-- 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 =
|
||||
config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack
|
||||
let exactprintOnly = viaGlobal || viaDebug
|
||||
where
|
||||
viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack
|
||||
viaDebug =
|
||||
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."
|
||||
|
|
@ -233,118 +268,158 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx
|
|||
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 "-- BRITANY_INCLUDE_HACK " ++ s else s
|
||||
let hackTransform =
|
||||
if hackAroundIncludes && not exactprintOnly then List.intercalate "\n" . fmap hackF . 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
|
||||
ExceptT.throwE 60
|
||||
Right (anns, parsedSource, hasCPP) -> do
|
||||
(inlineConf, perItemConf) <- case extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) of
|
||||
Left (err, input) -> do
|
||||
putErrorLn
|
||||
$ "Error: parse error in inline configuration:"
|
||||
putErrorLn err
|
||||
putErrorLn $ " in the string \"" ++ input ++ "\"."
|
||||
ExceptT.throwE 61
|
||||
Right c -> -- trace (showTree c) $
|
||||
pure c
|
||||
let moduleConf = cZipWith fromOptionIdentity config inlineConf
|
||||
when (config & _conf_debug .> _dconf_dump_ast_full .> confUnpack) $ do
|
||||
let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource
|
||||
trace ("---- ast ----\n" ++ show val) $ return ()
|
||||
(errsWarns, outSText) <- do
|
||||
if exactprintOnly
|
||||
then do
|
||||
pure ([], Text.pack $ ExactPrint.exactPrint parsedSource anns)
|
||||
else do
|
||||
let omitCheck = moduleConf & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack
|
||||
(ews, outRaw) <- if hasCPP || omitCheck
|
||||
then return $ pPrintModule moduleConf perItemConf anns parsedSource
|
||||
else liftIO $ pPrintModuleAndCheck moduleConf perItemConf anns parsedSource
|
||||
let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
|
||||
let out = TextL.toStrict $ if hackAroundIncludes
|
||||
then TextL.intercalate (TextL.pack "\n") $ fmap hackF $ TextL.splitOn (TextL.pack "\n") outRaw
|
||||
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 "-- BRITANY_INCLUDE_HACK " ++ s
|
||||
else s
|
||||
let hackTransform = if hackAroundIncludes && not exactprintOnly
|
||||
then List.intercalate "\n" . fmap hackF . 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
|
||||
ExceptT.throwE 60
|
||||
Right (anns, parsedSource, hasCPP) -> do
|
||||
(inlineConf, perItemConf) <-
|
||||
case
|
||||
extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource)
|
||||
of
|
||||
Left (err, input) -> do
|
||||
putErrorLn $ "Error: parse error in inline configuration:"
|
||||
putErrorLn err
|
||||
putErrorLn $ " in the string \"" ++ input ++ "\"."
|
||||
ExceptT.throwE 61
|
||||
Right c -> -- trace (showTree c) $
|
||||
pure c
|
||||
let moduleConf = cZipWith fromOptionIdentity config inlineConf
|
||||
when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do
|
||||
let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource
|
||||
trace ("---- ast ----\n" ++ show val) $ return ()
|
||||
(errsWarns, outSText) <- do
|
||||
if exactprintOnly
|
||||
then do
|
||||
pure ([], Text.pack $ ExactPrint.exactPrint parsedSource anns)
|
||||
else do
|
||||
let omitCheck =
|
||||
moduleConf
|
||||
& _conf_errorHandling
|
||||
.> _econf_omit_output_valid_check
|
||||
.> confUnpack
|
||||
(ews, outRaw) <- if hasCPP || omitCheck
|
||||
then return
|
||||
$ pPrintModule moduleConf perItemConf anns parsedSource
|
||||
else liftIO $ pPrintModuleAndCheck moduleConf
|
||||
perItemConf
|
||||
anns
|
||||
parsedSource
|
||||
let hackF s = fromMaybe s $ TextL.stripPrefix
|
||||
(TextL.pack "-- BRITANY_INCLUDE_HACK ")
|
||||
s
|
||||
let
|
||||
out = TextL.toStrict $ if hackAroundIncludes
|
||||
then
|
||||
TextL.intercalate (TextL.pack "\n")
|
||||
$ fmap hackF
|
||||
$ TextL.splitOn (TextL.pack "\n") outRaw
|
||||
else outRaw
|
||||
out' <- if moduleConf & _conf_obfuscate & confUnpack
|
||||
then lift $ obfuscate out
|
||||
else pure out
|
||||
pure $ (ews, out')
|
||||
let customErrOrder ErrorInput{} = 4
|
||||
customErrOrder LayoutWarning{} = 0 :: Int
|
||||
customErrOrder ErrorOutputCheck{} = 1
|
||||
customErrOrder ErrorUnusedComment{} = 2
|
||||
customErrOrder ErrorUnknownNode{} = 3
|
||||
customErrOrder ErrorMacroConfig{} = 5
|
||||
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 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)"
|
||||
(ErrorMacroConfig err input:_) -> do
|
||||
putErrorLn
|
||||
$ "Error: parse error in inline configuration:"
|
||||
putErrorLn err
|
||||
putErrorLn $ " in the string \"" ++ input ++ "\"."
|
||||
[] -> 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
|
||||
out' <- if moduleConf & _conf_obfuscate & confUnpack
|
||||
then lift $ obfuscate out
|
||||
else pure out
|
||||
pure $ (ews, out')
|
||||
let customErrOrder ErrorInput{} = 4
|
||||
customErrOrder LayoutWarning{} = 0 :: Int
|
||||
customErrOrder ErrorOutputCheck{} = 1
|
||||
customErrOrder ErrorUnusedComment{} = 2
|
||||
customErrOrder ErrorUnknownNode{} = 3
|
||||
customErrOrder ErrorMacroConfig{} = 5
|
||||
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 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)"
|
||||
(ErrorMacroConfig err input : _) -> do
|
||||
putErrorLn $ "Error: parse error in inline configuration:"
|
||||
putErrorLn err
|
||||
putErrorLn $ " in the string \"" ++ input ++ "\"."
|
||||
[] -> 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 $ Text.IO.putStr $ outSText
|
||||
Just p -> liftIO $ do
|
||||
isIdentical <- case inputPathM of
|
||||
Nothing -> pure False
|
||||
Just path -> do
|
||||
(== outSText) <$> Text.IO.readFile path
|
||||
-- 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.)
|
||||
unless isIdentical $ Text.IO.writeFile p $ outSText
|
||||
when shouldOutput
|
||||
$ addTraceSep (_conf_debug config)
|
||||
$ case outputPathM of
|
||||
Nothing -> liftIO $ Text.IO.putStr $ outSText
|
||||
Just p -> liftIO $ do
|
||||
isIdentical <- case inputPathM of
|
||||
Nothing -> pure False
|
||||
Just path -> do
|
||||
(== outSText) <$> Text.IO.readFile path
|
||||
-- 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.)
|
||||
unless isIdentical $ Text.IO.writeFile p $ outSText
|
||||
|
||||
when hasErrors $ ExceptT.throwE 70
|
||||
when hasErrors $ ExceptT.throwE 70
|
||||
where
|
||||
addTraceSep conf =
|
||||
if or
|
||||
|
|
|
|||
|
|
@ -17,8 +17,9 @@ where
|
|||
|
||||
#include "prelude.inc"
|
||||
|
||||
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
|
||||
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
|
||||
-- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 }
|
||||
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
|
||||
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
|
||||
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers
|
||||
|
||||
import Data.Data
|
||||
|
|
@ -27,9 +28,9 @@ import Data.HList.HList
|
|||
import qualified Data.Yaml
|
||||
import qualified Data.ByteString.Char8
|
||||
import Data.CZipWith
|
||||
import qualified UI.Butcher.Monadic as Butcher
|
||||
import qualified UI.Butcher.Monadic as Butcher
|
||||
|
||||
import qualified Data.Text.Lazy.Builder as Text.Builder
|
||||
import qualified Data.Text.Lazy.Builder as Text.Builder
|
||||
|
||||
import Language.Haskell.Brittany.Internal.Types
|
||||
import Language.Haskell.Brittany.Internal.Config.Types
|
||||
|
|
@ -50,15 +51,19 @@ import Language.Haskell.Brittany.Internal.Transformations.Par
|
|||
import Language.Haskell.Brittany.Internal.Transformations.Columns
|
||||
import Language.Haskell.Brittany.Internal.Transformations.Indent
|
||||
|
||||
import qualified GHC as GHC hiding (parseModule)
|
||||
import ApiAnnotation ( AnnKeywordId(..) )
|
||||
import GHC ( runGhc, GenLocated(L), moduleNameString )
|
||||
import SrcLoc ( SrcSpan )
|
||||
import qualified GHC as GHC
|
||||
hiding ( parseModule )
|
||||
import ApiAnnotation ( AnnKeywordId(..) )
|
||||
import GHC ( runGhc
|
||||
, GenLocated(L)
|
||||
, moduleNameString
|
||||
)
|
||||
import SrcLoc ( SrcSpan )
|
||||
import HsSyn
|
||||
import qualified DynFlags as GHC
|
||||
import qualified GHC.LanguageExtensions.Type as GHC
|
||||
import qualified DynFlags as GHC
|
||||
import qualified GHC.LanguageExtensions.Type as GHC
|
||||
|
||||
import Data.Char (isSpace)
|
||||
import Data.Char ( isSpace )
|
||||
|
||||
|
||||
|
||||
|
|
@ -267,7 +272,8 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do
|
|||
& confUnpack
|
||||
(ews, outRaw) <- if hasCPP || omitCheck
|
||||
then return $ pPrintModule moduleConfig perItemConf anns parsedSource
|
||||
else lift $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource
|
||||
else lift
|
||||
$ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource
|
||||
let hackF s = fromMaybe s
|
||||
$ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
|
||||
pure $ if hackAroundIncludes
|
||||
|
|
@ -303,30 +309,26 @@ pPrintModule
|
|||
-> GHC.ParsedSource
|
||||
-> ([BrittanyError], TextL.Text)
|
||||
pPrintModule conf inlineConf anns parsedModule =
|
||||
let
|
||||
((out, errs), debugStrings) =
|
||||
runIdentity
|
||||
$ MultiRWSS.runMultiRWSTNil
|
||||
$ MultiRWSS.withMultiWriterAW
|
||||
$ MultiRWSS.withMultiWriterAW
|
||||
$ MultiRWSS.withMultiWriterW
|
||||
$ MultiRWSS.withMultiReader anns
|
||||
$ MultiRWSS.withMultiReader conf
|
||||
$ MultiRWSS.withMultiReader inlineConf
|
||||
$ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns)
|
||||
$ do
|
||||
traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations
|
||||
$ annsDoc anns
|
||||
ppModule parsedModule
|
||||
tracer =
|
||||
if Seq.null debugStrings
|
||||
then
|
||||
id
|
||||
else
|
||||
trace ("---- DEBUGMESSAGES ---- ")
|
||||
. foldr (seq . join trace) id debugStrings
|
||||
in
|
||||
tracer $ (errs, Text.Builder.toLazyText out)
|
||||
let ((out, errs), debugStrings) =
|
||||
runIdentity
|
||||
$ MultiRWSS.runMultiRWSTNil
|
||||
$ MultiRWSS.withMultiWriterAW
|
||||
$ MultiRWSS.withMultiWriterAW
|
||||
$ MultiRWSS.withMultiWriterW
|
||||
$ MultiRWSS.withMultiReader anns
|
||||
$ MultiRWSS.withMultiReader conf
|
||||
$ MultiRWSS.withMultiReader inlineConf
|
||||
$ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns)
|
||||
$ do
|
||||
traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations
|
||||
$ annsDoc anns
|
||||
ppModule parsedModule
|
||||
tracer = if Seq.null debugStrings
|
||||
then id
|
||||
else
|
||||
trace ("---- DEBUGMESSAGES ---- ")
|
||||
. foldr (seq . join trace) id debugStrings
|
||||
in tracer $ (errs, Text.Builder.toLazyText out)
|
||||
-- unless () $ do
|
||||
--
|
||||
-- debugStrings `forM_` \s ->
|
||||
|
|
@ -374,8 +376,8 @@ parsePrintModuleTests conf filename input = do
|
|||
.> confUnpack
|
||||
(errs, ltext) <- if omitCheck
|
||||
then return $ pPrintModule moduleConf perItemConf anns parsedModule
|
||||
else
|
||||
lift $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule
|
||||
else lift
|
||||
$ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule
|
||||
if null errs
|
||||
then pure $ TextL.toStrict $ ltext
|
||||
else
|
||||
|
|
@ -426,7 +428,8 @@ parsePrintModuleTests conf filename input = do
|
|||
|
||||
toLocal :: Config -> ExactPrint.Anns -> PPMLocal a -> PPM a
|
||||
toLocal conf anns m = do
|
||||
(x, write) <- lift $ MultiRWSS.runMultiRWSTAW (conf :+: anns :+: HNil) HNil $ m
|
||||
(x, write) <-
|
||||
lift $ MultiRWSS.runMultiRWSTAW (conf :+: anns :+: HNil) HNil $ m
|
||||
MultiRWSS.mGetRawW >>= \w -> MultiRWSS.mPutRawW (w `mappend` write)
|
||||
pure x
|
||||
|
||||
|
|
@ -437,7 +440,7 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do
|
|||
let declAnnKey = ExactPrint.mkAnnKey decl
|
||||
let declBindingNames = getDeclBindingNames decl
|
||||
inlineConf <- mAsk
|
||||
let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf
|
||||
let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf
|
||||
let mBindingConfs =
|
||||
declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf
|
||||
filteredAnns <- mAsk
|
||||
|
|
@ -449,8 +452,8 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do
|
|||
|
||||
config <- mAsk
|
||||
|
||||
let config' = cZipWith fromOptionIdentity config $ mconcat
|
||||
(catMaybes (mBindingConfs ++ [mDeclConf]))
|
||||
let config' = cZipWith fromOptionIdentity config
|
||||
$ mconcat (catMaybes (mBindingConfs ++ [mDeclConf]))
|
||||
|
||||
let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack
|
||||
toLocal config' filteredAnns $ do
|
||||
|
|
@ -486,13 +489,14 @@ getDeclBindingNames :: LHsDecl GhcPs -> [String]
|
|||
getDeclBindingNames (L _ decl) = case decl of
|
||||
SigD (TypeSig ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n)
|
||||
ValD (FunBind (L _ n) _ _ _ _) -> [Text.unpack $ rdrNameToText n]
|
||||
_ -> []
|
||||
_ -> []
|
||||
|
||||
|
||||
-- Prints the information associated with the module annotation
|
||||
-- This includes the imports
|
||||
ppPreamble :: GenLocated SrcSpan (HsModule GhcPs)
|
||||
-> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)]
|
||||
ppPreamble
|
||||
:: GenLocated SrcSpan (HsModule GhcPs)
|
||||
-> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)]
|
||||
ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do
|
||||
filteredAnns <- mAsk <&> \annMap ->
|
||||
Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap
|
||||
|
|
@ -550,8 +554,8 @@ ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do
|
|||
|
||||
if shouldReformatPreamble
|
||||
then toLocal config filteredAnns' $ withTransformedAnns lmod $ do
|
||||
briDoc <- briDocMToPPM $ layoutModule lmod
|
||||
layoutBriDoc briDoc
|
||||
briDoc <- briDocMToPPM $ layoutModule lmod
|
||||
layoutBriDoc briDoc
|
||||
else
|
||||
let emptyModule = L loc m { hsmodDecls = [] }
|
||||
in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule
|
||||
|
|
@ -567,14 +571,14 @@ _bindHead :: HsBind GhcPs -> String
|
|||
_bindHead = \case
|
||||
FunBind fId _ _ _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId)
|
||||
PatBind _pat _ _ _ ([], []) -> "PatBind smth"
|
||||
_ -> "unknown bind"
|
||||
_ -> "unknown bind"
|
||||
|
||||
|
||||
|
||||
layoutBriDoc :: BriDocNumbered -> PPMLocal ()
|
||||
layoutBriDoc briDoc = do
|
||||
-- first step: transform the briDoc.
|
||||
briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do
|
||||
briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do
|
||||
-- Note that briDoc is BriDocNumbered, but state type is BriDoc.
|
||||
-- That's why the alt-transform looks a bit special here.
|
||||
traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw
|
||||
|
|
@ -583,26 +587,33 @@ layoutBriDoc briDoc = do
|
|||
$ briDoc
|
||||
-- bridoc transformation: remove alts
|
||||
transformAlts briDoc >>= mSet
|
||||
mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-alt"
|
||||
_dconf_dump_bridoc_simpl_alt
|
||||
mGet
|
||||
>>= briDocToDoc
|
||||
.> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt
|
||||
-- bridoc transformation: float stuff in
|
||||
mGet >>= transformSimplifyFloating .> mSet
|
||||
mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-floating"
|
||||
_dconf_dump_bridoc_simpl_floating
|
||||
mGet
|
||||
>>= briDocToDoc
|
||||
.> traceIfDumpConf "bridoc post-floating"
|
||||
_dconf_dump_bridoc_simpl_floating
|
||||
-- bridoc transformation: par removal
|
||||
mGet >>= transformSimplifyPar .> mSet
|
||||
mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-par"
|
||||
_dconf_dump_bridoc_simpl_par
|
||||
mGet
|
||||
>>= briDocToDoc
|
||||
.> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par
|
||||
-- bridoc transformation: float stuff in
|
||||
mGet >>= transformSimplifyColumns .> mSet
|
||||
mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-columns"
|
||||
_dconf_dump_bridoc_simpl_columns
|
||||
mGet
|
||||
>>= briDocToDoc
|
||||
.> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns
|
||||
-- bridoc transformation: indent
|
||||
mGet >>= transformSimplifyIndent .> mSet
|
||||
mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-indent"
|
||||
_dconf_dump_bridoc_simpl_indent
|
||||
mGet >>= briDocToDoc .> traceIfDumpConf "bridoc final"
|
||||
_dconf_dump_bridoc_final
|
||||
mGet
|
||||
>>= briDocToDoc
|
||||
.> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent
|
||||
mGet
|
||||
>>= briDocToDoc
|
||||
.> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final
|
||||
-- -- convert to Simple type
|
||||
-- simpl <- mGet <&> transformToSimple
|
||||
-- return simpl
|
||||
|
|
@ -627,6 +638,6 @@ layoutBriDoc briDoc = do
|
|||
let remainingComments =
|
||||
extractAllComments =<< Map.elems (_lstate_comments state')
|
||||
remainingComments
|
||||
`forM_` (fst .> show .> ErrorUnusedComment .> (:[]) .> mTell)
|
||||
`forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell)
|
||||
|
||||
return $ ()
|
||||
|
|
|
|||
Loading…
Reference in New Issue