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

Refactor/Auto-format Main, Brittany.Internal

pull/153/head
Lennart Spitzner 2018-06-04 17:06:23 +02:00
parent 57c48f64c1
commit 6725d0e119
2 changed files with 324 additions and 238 deletions
src-brittany
src/Language/Haskell/Brittany

427
src-brittany/Main.hs
View File

@ -6,22 +6,24 @@ module Main where
#include "prelude.inc" #include "prelude.inc"
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 }
import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types 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 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 qualified Data.Monoid
import Text.Read (Read(..)) import Text.Read ( Read(..) )
import qualified Text.ParserCombinators.ReadP as ReadP import qualified Text.ParserCombinators.ReadP as ReadP
import qualified Text.ParserCombinators.ReadPrec as ReadPrec import qualified Text.ParserCombinators.ReadPrec as ReadPrec
import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Text.Lazy.Builder as Text.Builder
import Control.Monad (zipWithM) import Control.Monad ( zipWithM )
import Data.CZipWith 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.Types
import Language.Haskell.Brittany.Internal 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.Utils
import Language.Haskell.Brittany.Internal.Obfuscation import Language.Haskell.Brittany.Internal.Obfuscation
import qualified Text.PrettyPrint as PP import qualified Text.PrettyPrint as PP
import DataTreePrint import DataTreePrint
import UI.Butcher.Monadic import UI.Butcher.Monadic
import qualified System.Exit import qualified System.Exit
import qualified System.Directory as Directory import qualified System.Directory as Directory
import qualified System.FilePath.Posix as FilePath import qualified System.FilePath.Posix as FilePath
import qualified DynFlags as GHC import qualified DynFlags as GHC
import qualified GHC.LanguageExtensions.Type as GHC import qualified GHC.LanguageExtensions.Type as GHC
import Paths_brittany
import Paths_brittany
data WriteMode = Display | Inplace data WriteMode = Display | Inplace
@ -73,16 +76,16 @@ helpDoc = PP.vcat $ List.intersperse
] ]
, parDoc $ "Example invocations:" , parDoc $ "Example invocations:"
, PP.hang (PP.text "") 2 $ PP.vcat , PP.hang (PP.text "") 2 $ PP.vcat
[ PP.text "brittany" [ PP.text "brittany"
, PP.nest 2 $ PP.text "read from stdin, output to stdout" , PP.nest 2 $ PP.text "read from stdin, output to stdout"
] ]
, PP.hang (PP.text "") 2 $ PP.vcat , PP.hang (PP.text "") 2 $ PP.vcat
[ PP.text "brittany --indent=4 --write-mode=inplace *.hs" [ PP.text "brittany --indent=4 --write-mode=inplace *.hs"
, PP.nest 2 $ PP.vcat , PP.nest 2 $ PP.vcat
[ PP.text "run on all modules in current directory (no backup!)" [ PP.text "run on all modules in current directory (no backup!)"
, PP.text "4 spaces indentation" , PP.text "4 spaces indentation"
]
] ]
]
, parDocW , parDocW
[ "This program is written carefully and contains safeguards to ensure" [ "This program is written carefully and contains safeguards to ensure"
, "the output is syntactically valid and that no comments are removed." , "the output is syntactically valid and that no comments are removed."
@ -93,9 +96,14 @@ helpDoc = PP.vcat $ List.intersperse
, "codebase without having backups." , "codebase without having backups."
] ]
, parDoc $ "There is NO WARRANTY, to the extent permitted by law." , 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 $ "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 licenseDoc :: PP.Doc
@ -130,29 +138,39 @@ mainCmdParser helpDesc = do
addCmd "license" $ addCmdImpl $ print $ licenseDoc addCmd "license" $ addCmdImpl $ print $ licenseDoc
-- addButcherDebugCommand -- addButcherDebugCommand
reorderStart reorderStart
printHelp <- addSimpleBoolFlag "h" ["help"] mempty printHelp <- addSimpleBoolFlag "h" ["help"] mempty
printVersion <- addSimpleBoolFlag "" ["version"] mempty printVersion <- addSimpleBoolFlag "" ["version"] mempty
printLicense <- addSimpleBoolFlag "" ["license"] mempty printLicense <- addSimpleBoolFlag "" ["license"] mempty
configPaths <- addFlagStringParams "" ["config-file"] "PATH" (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? configPaths <- addFlagStringParams ""
["config-file"]
"PATH"
(flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ?
cmdlineConfig <- cmdlineConfigParser cmdlineConfig <- cmdlineConfigParser
suppressOutput <- addSimpleBoolFlag suppressOutput <- addSimpleBoolFlag
"" ""
["suppress-output"] ["suppress-output"]
(flagHelp $ parDoc "suppress the regular output, i.e. the transformed haskell source") (flagHelp $ parDoc
_verbosity <- addSimpleCountFlag "v" ["verbose"] (flagHelp $ parDoc "[currently without effect; TODO]") "suppress the regular output, i.e. the transformed haskell source"
writeMode <- addFlagReadParam )
_verbosity <- addSimpleCountFlag
"v"
["verbose"]
(flagHelp $ parDoc "[currently without effect; TODO]")
writeMode <- addFlagReadParam
"" ""
["write-mode"] ["write-mode"]
"(display|inplace)" "(display|inplace)"
( flagHelp ( flagHelp
( PP.vcat (PP.vcat
[ PP.text "display: output for any input(s) goes to stdout" [ PP.text "display: output for any input(s) goes to stdout"
, PP.text "inplace: override respective input file (without backup!)" , PP.text "inplace: override respective input file (without backup!)"
] ]
) )
Data.Monoid.<> flagDefault Display 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 reorderStop
addCmdImpl $ void $ do addCmdImpl $ void $ do
when printLicense $ do when printLicense $ do
@ -165,29 +183,39 @@ mainCmdParser helpDesc = do
putStrLn $ "There is NO WARRANTY, to the extent permitted by law." putStrLn $ "There is NO WARRANTY, to the extent permitted by law."
System.Exit.exitSuccess System.Exit.exitSuccess
when printHelp $ do 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 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 let outputPaths = case writeMode of
Display -> repeat Nothing Display -> repeat Nothing
Inplace -> inputPaths Inplace -> inputPaths
configsToLoad <- liftIO $ if null configPaths configsToLoad <- liftIO $ if null configPaths
then maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath) then
else pure configPaths maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath)
else pure configPaths
config <- runMaybeT (readConfigsWithUserConfig cmdlineConfig configsToLoad) >>= \case config <-
Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) runMaybeT (readConfigsWithUserConfig cmdlineConfig configsToLoad)
Just x -> return x >>= \case
when (config & _conf_debug & _dconf_dump_config & confUnpack) $ Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53)
trace (showConfigYaml config) $ return () 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 case results of
xs | all Data.Either.isRight xs -> pure () xs | all Data.Either.isRight xs -> pure ()
[Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x) [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 -- | 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 -- ^ input filepath; stdin if Nothing.
-> Maybe FilePath.FilePath -- ^ output filepath; stdout if Nothing. -> Maybe FilePath.FilePath -- ^ output filepath; stdout if Nothing.
-> IO (Either Int ()) -- ^ Either an errorNo, or success. -> IO (Either Int ()) -- ^ Either an errorNo, or success.
coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runExceptT $ do coreIO putErrorLnIO config suppressOutput inputPathM outputPathM =
let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () ExceptT.runExceptT $ do
let ghcOptions = config & _conf_forward & _options_ghc & runIdentity let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO ()
-- there is a good of code duplication between the following code and the let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
-- `pureModuleTransform` function. Unfortunately, there are also a good -- there is a good of code duplication between the following code and the
-- amount of slight differences: This module is a bit more verbose, and -- `pureModuleTransform` function. Unfortunately, there are also a good
-- it tries to use the full-blown `parseModule` function which supports -- amount of slight differences: This module is a bit more verbose, and
-- CPP (but requires the input to be a file..). -- it tries to use the full-blown `parseModule` function which supports
let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack -- CPP (but requires the input to be a file..).
-- the flag will do the following: insert a marker string let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack
-- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with -- the flag will do the following: insert a marker string
-- "#include" before processing (parsing) input; and remove that marker -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with
-- string from the transformation output. -- "#include" before processing (parsing) input; and remove that marker
-- The flag is intentionally misspelled to prevent clashing with -- string from the transformation output.
-- inline-config stuff. -- The flag is intentionally misspelled to prevent clashing with
let hackAroundIncludes = config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack -- inline-config stuff.
let exactprintOnly = (config & _conf_roundtrip_exactprint_only & confUnpack) let hackAroundIncludes =
|| (config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack) config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack
let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags 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 then case cppMode of
CPPModeAbort -> do CPPModeAbort -> do
return $ Left "Encountered -XCPP. Aborting." return $ Left "Encountered -XCPP. Aborting."
@ -233,118 +268,158 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx
return $ Right True return $ Right True
CPPModeNowarn -> return $ Right True CPPModeNowarn -> return $ Right True
else return $ Right False else return $ Right False
parseResult <- case inputPathM of parseResult <- case inputPathM of
Nothing -> do Nothing -> do
-- TODO: refactor this hack to not be mixed into parsing logic -- 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 hackF s = if "#include" `isPrefixOf` s
let hackTransform = then "-- BRITANY_INCLUDE_HACK " ++ s
if hackAroundIncludes && not exactprintOnly then List.intercalate "\n" . fmap hackF . lines' else id else s
inputString <- liftIO $ System.IO.hGetContents System.IO.stdin let hackTransform = if hackAroundIncludes && not exactprintOnly
liftIO $ parseModuleFromString ghcOptions "stdin" cppCheckFunc (hackTransform inputString) then List.intercalate "\n" . fmap hackF . lines'
Just p -> liftIO $ parseModule ghcOptions p cppCheckFunc else id
case parseResult of inputString <- liftIO $ System.IO.hGetContents System.IO.stdin
Left left -> do liftIO $ parseModuleFromString ghcOptions
putErrorLn "parse error:" "stdin"
putErrorLn $ show left cppCheckFunc
ExceptT.throwE 60 (hackTransform inputString)
Right (anns, parsedSource, hasCPP) -> do Just p -> liftIO $ parseModule ghcOptions p cppCheckFunc
(inlineConf, perItemConf) <- case extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) of case parseResult of
Left (err, input) -> do Left left -> do
putErrorLn putErrorLn "parse error:"
$ "Error: parse error in inline configuration:" putErrorLn $ show left
putErrorLn err ExceptT.throwE 60
putErrorLn $ " in the string \"" ++ input ++ "\"." Right (anns, parsedSource, hasCPP) -> do
ExceptT.throwE 61 (inlineConf, perItemConf) <-
Right c -> -- trace (showTree c) $ case
pure c extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource)
let moduleConf = cZipWith fromOptionIdentity config inlineConf of
when (config & _conf_debug .> _dconf_dump_ast_full .> confUnpack) $ do Left (err, input) -> do
let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource putErrorLn $ "Error: parse error in inline configuration:"
trace ("---- ast ----\n" ++ show val) $ return () putErrorLn err
(errsWarns, outSText) <- do putErrorLn $ " in the string \"" ++ input ++ "\"."
if exactprintOnly ExceptT.throwE 61
then do Right c -> -- trace (showTree c) $
pure ([], Text.pack $ ExactPrint.exactPrint parsedSource anns) pure c
else do let moduleConf = cZipWith fromOptionIdentity config inlineConf
let omitCheck = moduleConf & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do
(ews, outRaw) <- if hasCPP || omitCheck let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource
then return $ pPrintModule moduleConf perItemConf anns parsedSource trace ("---- ast ----\n" ++ show val) $ return ()
else liftIO $ pPrintModuleAndCheck moduleConf perItemConf anns parsedSource (errsWarns, outSText) <- do
let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s if exactprintOnly
let out = TextL.toStrict $ if hackAroundIncludes then do
then TextL.intercalate (TextL.pack "\n") $ fmap hackF $ TextL.splitOn (TextL.pack "\n") outRaw 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 else outRaw
out' <- if moduleConf & _conf_obfuscate & confUnpack out' <- if moduleConf & _conf_obfuscate & confUnpack
then lift $ obfuscate out then lift $ obfuscate out
else pure out else pure out
pure $ (ews, out') pure $ (ews, out')
let customErrOrder ErrorInput{} = 4 let customErrOrder ErrorInput{} = 4
customErrOrder LayoutWarning{} = 0 :: Int customErrOrder LayoutWarning{} = 0 :: Int
customErrOrder ErrorOutputCheck{} = 1 customErrOrder ErrorOutputCheck{} = 1
customErrOrder ErrorUnusedComment{} = 2 customErrOrder ErrorUnusedComment{} = 2
customErrOrder ErrorUnknownNode{} = 3 customErrOrder ErrorUnknownNode{} = 3
customErrOrder ErrorMacroConfig{} = 5 customErrOrder ErrorMacroConfig{} = 5
when (not $ null errsWarns) $ do when (not $ null errsWarns) $ do
let groupedErrsWarns = Data.List.Extra.groupOn customErrOrder $ List.sortOn customErrOrder $ errsWarns let groupedErrsWarns =
groupedErrsWarns `forM_` \case Data.List.Extra.groupOn customErrOrder
(ErrorOutputCheck{}:_) -> do $ List.sortOn customErrOrder
putErrorLn $ "ERROR: brittany pretty printer" ++ " returned syntactically invalid result." $ errsWarns
(ErrorInput str:_) -> do groupedErrsWarns `forM_` \case
putErrorLn $ "ERROR: parse error: " ++ str (ErrorOutputCheck{} : _) -> do
uns@(ErrorUnknownNode{}:_) -> do putErrorLn
putErrorLn $ "ERROR: encountered unknown syntactical constructs:" $ "ERROR: brittany pretty printer"
uns `forM_` \case ++ " returned syntactically invalid result."
ErrorUnknownNode str ast -> do (ErrorInput str : _) -> do
putErrorLn str putErrorLn $ "ERROR: parse error: " ++ str
when (config & _conf_debug & _dconf_dump_ast_unknown & confUnpack) $ do uns@(ErrorUnknownNode{} : _) -> do
putErrorLn $ " " ++ show (astToDoc ast) putErrorLn $ "ERROR: encountered unknown syntactical constructs:"
_ -> error "cannot happen (TM)" uns `forM_` \case
warns@(LayoutWarning{}:_) -> do ErrorUnknownNode str ast -> do
putErrorLn $ "WARNINGS:" putErrorLn str
warns `forM_` \case when
LayoutWarning str -> putErrorLn str ( config
_ -> error "cannot happen (TM)" & _conf_debug
unused@(ErrorUnusedComment{}:_) -> do & _dconf_dump_ast_unknown
putErrorLn & confUnpack
$ "Error: detected unprocessed comments." )
++ " The transformation output will most likely" $ do
++ " not contain some of the comments" putErrorLn $ " " ++ show (astToDoc ast)
++ " present in the input haskell source file." _ -> error "cannot happen (TM)"
putErrorLn $ "Affected are the following comments:" warns@(LayoutWarning{} : _) -> do
unused `forM_` \case putErrorLn $ "WARNINGS:"
ErrorUnusedComment str -> putErrorLn str warns `forM_` \case
_ -> error "cannot happen (TM)" LayoutWarning str -> putErrorLn str
(ErrorMacroConfig err input:_) -> do _ -> error "cannot happen (TM)"
putErrorLn unused@(ErrorUnusedComment{} : _) -> do
$ "Error: parse error in inline configuration:" putErrorLn
putErrorLn err $ "Error: detected unprocessed comments."
putErrorLn $ " in the string \"" ++ input ++ "\"." ++ " The transformation output will most likely"
[] -> error "cannot happen" ++ " not contain some of the comments"
-- TODO: don't output anything when there are errors unless user ++ " present in the input haskell source file."
-- adds some override? putErrorLn $ "Affected are the following comments:"
let hasErrors = case config & _conf_errorHandling & _econf_Werror & confUnpack of unused `forM_` \case
False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) ErrorUnusedComment str -> putErrorLn str
True -> not $ null errsWarns _ -> error "cannot happen (TM)"
outputOnErrs = config & _conf_errorHandling & _econf_produceOutputOnErrors & confUnpack (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) shouldOutput = not suppressOutput && (not hasErrors || outputOnErrs)
when shouldOutput $ addTraceSep (_conf_debug config) $ case outputPathM of when shouldOutput
Nothing -> liftIO $ Text.IO.putStr $ outSText $ addTraceSep (_conf_debug config)
Just p -> liftIO $ do $ case outputPathM of
isIdentical <- case inputPathM of Nothing -> liftIO $ Text.IO.putStr $ outSText
Nothing -> pure False Just p -> liftIO $ do
Just path -> do isIdentical <- case inputPathM of
(== outSText) <$> Text.IO.readFile path Nothing -> pure False
-- The above means we read the file twice, but the Just path -> do
-- GHC API does not really expose the source it (== outSText) <$> Text.IO.readFile path
-- read. Should be in cache still anyways. -- The above means we read the file twice, but the
-- -- GHC API does not really expose the source it
-- We do not use TextL.IO.readFile because lazy IO is evil. -- read. Should be in cache still anyways.
-- (not identical -> read is not finished -> handle still open -> --
-- write below crashes - evil.) -- We do not use TextL.IO.readFile because lazy IO is evil.
unless isIdentical $ Text.IO.writeFile p $ outSText -- (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 where
addTraceSep conf = addTraceSep conf =
if or if or

135
src/Language/Haskell/Brittany/Internal.hs
View File

@ -17,8 +17,9 @@ where
#include "prelude.inc" #include "prelude.inc"
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 }
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint 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 qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers
import Data.Data import Data.Data
@ -27,9 +28,9 @@ import Data.HList.HList
import qualified Data.Yaml import qualified Data.Yaml
import qualified Data.ByteString.Char8 import qualified Data.ByteString.Char8
import Data.CZipWith 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.Types
import Language.Haskell.Brittany.Internal.Config.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.Columns
import Language.Haskell.Brittany.Internal.Transformations.Indent import Language.Haskell.Brittany.Internal.Transformations.Indent
import qualified GHC as GHC hiding (parseModule) import qualified GHC as GHC
import ApiAnnotation ( AnnKeywordId(..) ) hiding ( parseModule )
import GHC ( runGhc, GenLocated(L), moduleNameString ) import ApiAnnotation ( AnnKeywordId(..) )
import SrcLoc ( SrcSpan ) import GHC ( runGhc
, GenLocated(L)
, moduleNameString
)
import SrcLoc ( SrcSpan )
import HsSyn import HsSyn
import qualified DynFlags as GHC import qualified DynFlags as GHC
import qualified GHC.LanguageExtensions.Type 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 & confUnpack
(ews, outRaw) <- if hasCPP || omitCheck (ews, outRaw) <- if hasCPP || omitCheck
then return $ pPrintModule moduleConfig perItemConf anns parsedSource 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 let hackF s = fromMaybe s
$ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
pure $ if hackAroundIncludes pure $ if hackAroundIncludes
@ -303,30 +309,26 @@ pPrintModule
-> GHC.ParsedSource -> GHC.ParsedSource
-> ([BrittanyError], TextL.Text) -> ([BrittanyError], TextL.Text)
pPrintModule conf inlineConf anns parsedModule = pPrintModule conf inlineConf anns parsedModule =
let let ((out, errs), debugStrings) =
((out, errs), debugStrings) = runIdentity
runIdentity $ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.runMultiRWSTNil $ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterAW $ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterAW $ MultiRWSS.withMultiWriterW
$ MultiRWSS.withMultiWriterW $ MultiRWSS.withMultiReader anns
$ MultiRWSS.withMultiReader anns $ MultiRWSS.withMultiReader conf
$ MultiRWSS.withMultiReader conf $ MultiRWSS.withMultiReader inlineConf
$ MultiRWSS.withMultiReader inlineConf $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns)
$ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) $ do
$ do traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations
traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations $ annsDoc anns
$ annsDoc anns ppModule parsedModule
ppModule parsedModule tracer = if Seq.null debugStrings
tracer = then id
if Seq.null debugStrings else
then trace ("---- DEBUGMESSAGES ---- ")
id . foldr (seq . join trace) id debugStrings
else in tracer $ (errs, Text.Builder.toLazyText out)
trace ("---- DEBUGMESSAGES ---- ")
. foldr (seq . join trace) id debugStrings
in
tracer $ (errs, Text.Builder.toLazyText out)
-- unless () $ do -- unless () $ do
-- --
-- debugStrings `forM_` \s -> -- debugStrings `forM_` \s ->
@ -374,8 +376,8 @@ parsePrintModuleTests conf filename input = do
.> confUnpack .> confUnpack
(errs, ltext) <- if omitCheck (errs, ltext) <- if omitCheck
then return $ pPrintModule moduleConf perItemConf anns parsedModule then return $ pPrintModule moduleConf perItemConf anns parsedModule
else else lift
lift $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule
if null errs if null errs
then pure $ TextL.toStrict $ ltext then pure $ TextL.toStrict $ ltext
else else
@ -426,7 +428,8 @@ parsePrintModuleTests conf filename input = do
toLocal :: Config -> ExactPrint.Anns -> PPMLocal a -> PPM a toLocal :: Config -> ExactPrint.Anns -> PPMLocal a -> PPM a
toLocal conf anns m = do 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) MultiRWSS.mGetRawW >>= \w -> MultiRWSS.mPutRawW (w `mappend` write)
pure x pure x
@ -437,7 +440,7 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do
let declAnnKey = ExactPrint.mkAnnKey decl let declAnnKey = ExactPrint.mkAnnKey decl
let declBindingNames = getDeclBindingNames decl let declBindingNames = getDeclBindingNames decl
inlineConf <- mAsk inlineConf <- mAsk
let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf
let mBindingConfs = let mBindingConfs =
declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf
filteredAnns <- mAsk filteredAnns <- mAsk
@ -449,8 +452,8 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do
config <- mAsk config <- mAsk
let config' = cZipWith fromOptionIdentity config $ mconcat let config' = cZipWith fromOptionIdentity config
(catMaybes (mBindingConfs ++ [mDeclConf])) $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf]))
let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack
toLocal config' filteredAnns $ do toLocal config' filteredAnns $ do
@ -486,13 +489,14 @@ getDeclBindingNames :: LHsDecl GhcPs -> [String]
getDeclBindingNames (L _ decl) = case decl of getDeclBindingNames (L _ decl) = case decl of
SigD (TypeSig ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) SigD (TypeSig ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n)
ValD (FunBind (L _ n) _ _ _ _) -> [Text.unpack $ rdrNameToText n] ValD (FunBind (L _ n) _ _ _ _) -> [Text.unpack $ rdrNameToText n]
_ -> [] _ -> []
-- Prints the information associated with the module annotation -- Prints the information associated with the module annotation
-- This includes the imports -- This includes the imports
ppPreamble :: GenLocated SrcSpan (HsModule GhcPs) ppPreamble
-> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] :: GenLocated SrcSpan (HsModule GhcPs)
-> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)]
ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do
filteredAnns <- mAsk <&> \annMap -> filteredAnns <- mAsk <&> \annMap ->
Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap
@ -550,8 +554,8 @@ ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do
if shouldReformatPreamble if shouldReformatPreamble
then toLocal config filteredAnns' $ withTransformedAnns lmod $ do then toLocal config filteredAnns' $ withTransformedAnns lmod $ do
briDoc <- briDocMToPPM $ layoutModule lmod briDoc <- briDocMToPPM $ layoutModule lmod
layoutBriDoc briDoc layoutBriDoc briDoc
else else
let emptyModule = L loc m { hsmodDecls = [] } let emptyModule = L loc m { hsmodDecls = [] }
in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule
@ -567,14 +571,14 @@ _bindHead :: HsBind GhcPs -> String
_bindHead = \case _bindHead = \case
FunBind fId _ _ _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) FunBind fId _ _ _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId)
PatBind _pat _ _ _ ([], []) -> "PatBind smth" PatBind _pat _ _ _ ([], []) -> "PatBind smth"
_ -> "unknown bind" _ -> "unknown bind"
layoutBriDoc :: BriDocNumbered -> PPMLocal () layoutBriDoc :: BriDocNumbered -> PPMLocal ()
layoutBriDoc briDoc = do layoutBriDoc briDoc = do
-- first step: transform the briDoc. -- 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. -- Note that briDoc is BriDocNumbered, but state type is BriDoc.
-- That's why the alt-transform looks a bit special here. -- That's why the alt-transform looks a bit special here.
traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw
@ -583,26 +587,33 @@ layoutBriDoc briDoc = do
$ briDoc $ briDoc
-- bridoc transformation: remove alts -- bridoc transformation: remove alts
transformAlts briDoc >>= mSet transformAlts briDoc >>= mSet
mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-alt" mGet
_dconf_dump_bridoc_simpl_alt >>= briDocToDoc
.> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt
-- bridoc transformation: float stuff in -- bridoc transformation: float stuff in
mGet >>= transformSimplifyFloating .> mSet mGet >>= transformSimplifyFloating .> mSet
mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-floating" mGet
_dconf_dump_bridoc_simpl_floating >>= briDocToDoc
.> traceIfDumpConf "bridoc post-floating"
_dconf_dump_bridoc_simpl_floating
-- bridoc transformation: par removal -- bridoc transformation: par removal
mGet >>= transformSimplifyPar .> mSet mGet >>= transformSimplifyPar .> mSet
mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-par" mGet
_dconf_dump_bridoc_simpl_par >>= briDocToDoc
.> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par
-- bridoc transformation: float stuff in -- bridoc transformation: float stuff in
mGet >>= transformSimplifyColumns .> mSet mGet >>= transformSimplifyColumns .> mSet
mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-columns" mGet
_dconf_dump_bridoc_simpl_columns >>= briDocToDoc
.> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns
-- bridoc transformation: indent -- bridoc transformation: indent
mGet >>= transformSimplifyIndent .> mSet mGet >>= transformSimplifyIndent .> mSet
mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-indent" mGet
_dconf_dump_bridoc_simpl_indent >>= briDocToDoc
mGet >>= briDocToDoc .> traceIfDumpConf "bridoc final" .> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent
_dconf_dump_bridoc_final mGet
>>= briDocToDoc
.> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final
-- -- convert to Simple type -- -- convert to Simple type
-- simpl <- mGet <&> transformToSimple -- simpl <- mGet <&> transformToSimple
-- return simpl -- return simpl
@ -627,6 +638,6 @@ layoutBriDoc briDoc = do
let remainingComments = let remainingComments =
extractAllComments =<< Map.elems (_lstate_comments state') extractAllComments =<< Map.elems (_lstate_comments state')
remainingComments remainingComments
`forM_` (fst .> show .> ErrorUnusedComment .> (:[]) .> mTell) `forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell)
return $ () return $ ()