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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

179
src-brittany/Main.hs
View File

@ -6,19 +6,21 @@ module Main where
#include "prelude.inc" #include "prelude.inc"
-- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 }
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate 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.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
@ -45,6 +47,7 @@ import qualified GHC.LanguageExtensions.Type as GHC
import Paths_brittany import Paths_brittany
data WriteMode = Display | Inplace data WriteMode = Display | Inplace
instance Read WriteMode where instance Read WriteMode where
@ -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
@ -133,26 +141,36 @@ mainCmdParser helpDesc = do
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"
)
_verbosity <- addSimpleCountFlag
"v"
["verbose"]
(flagHelp $ parDoc "[currently without effect; TODO]")
writeMode <- addFlagReadParam 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,25 +183,35 @@ 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
maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath)
else pure configPaths else pure configPaths
config <- runMaybeT (readConfigsWithUserConfig cmdlineConfig configsToLoad) >>= \case config <-
runMaybeT (readConfigsWithUserConfig cmdlineConfig configsToLoad)
>>= \case
Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53)
Just x -> return x Just x -> return x
when (config & _conf_debug & _dconf_dump_config & confUnpack) $ when (config & _conf_debug & _dconf_dump_config & confUnpack)
trace (showConfigYaml config) $ return () $ 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)
@ -202,7 +230,8 @@ 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 =
ExceptT.runExceptT $ do
let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO ()
let ghcOptions = config & _conf_forward & _options_ghc & runIdentity let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
-- there is a good of code duplication between the following code and the -- there is a good of code duplication between the following code and the
@ -217,10 +246,16 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx
-- string from the transformation output. -- string from the transformation output.
-- The flag is intentionally misspelled to prevent clashing with -- The flag is intentionally misspelled to prevent clashing with
-- inline-config stuff. -- inline-config stuff.
let hackAroundIncludes = config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack let hackAroundIncludes =
let exactprintOnly = (config & _conf_roundtrip_exactprint_only & confUnpack) config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack
|| (config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack) let exactprintOnly = viaGlobal || viaDebug
let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags 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."
@ -236,11 +271,17 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx
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
let hackTransform = if hackAroundIncludes && not exactprintOnly
then List.intercalate "\n" . fmap hackF . lines'
else id
inputString <- liftIO $ System.IO.hGetContents System.IO.stdin inputString <- liftIO $ System.IO.hGetContents System.IO.stdin
liftIO $ parseModuleFromString ghcOptions "stdin" cppCheckFunc (hackTransform inputString) liftIO $ parseModuleFromString ghcOptions
"stdin"
cppCheckFunc
(hackTransform inputString)
Just p -> liftIO $ parseModule ghcOptions p cppCheckFunc Just p -> liftIO $ parseModule ghcOptions p cppCheckFunc
case parseResult of case parseResult of
Left left -> do Left left -> do
@ -248,17 +289,19 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx
putErrorLn $ show left putErrorLn $ show left
ExceptT.throwE 60 ExceptT.throwE 60
Right (anns, parsedSource, hasCPP) -> do Right (anns, parsedSource, hasCPP) -> do
(inlineConf, perItemConf) <- case extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) of (inlineConf, perItemConf) <-
case
extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource)
of
Left (err, input) -> do Left (err, input) -> do
putErrorLn putErrorLn $ "Error: parse error in inline configuration:"
$ "Error: parse error in inline configuration:"
putErrorLn err putErrorLn err
putErrorLn $ " in the string \"" ++ input ++ "\"." putErrorLn $ " in the string \"" ++ input ++ "\"."
ExceptT.throwE 61 ExceptT.throwE 61
Right c -> -- trace (showTree c) $ Right c -> -- trace (showTree c) $
pure c pure c
let moduleConf = cZipWith fromOptionIdentity config inlineConf let moduleConf = cZipWith fromOptionIdentity config inlineConf
when (config & _conf_debug .> _dconf_dump_ast_full .> confUnpack) $ do when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do
let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource
trace ("---- ast ----\n" ++ show val) $ return () trace ("---- ast ----\n" ++ show val) $ return ()
(errsWarns, outSText) <- do (errsWarns, outSText) <- do
@ -266,13 +309,27 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx
then do then do
pure ([], Text.pack $ ExactPrint.exactPrint parsedSource anns) pure ([], Text.pack $ ExactPrint.exactPrint parsedSource anns)
else do else do
let omitCheck = moduleConf & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack let omitCheck =
moduleConf
& _conf_errorHandling
.> _econf_omit_output_valid_check
.> confUnpack
(ews, outRaw) <- if hasCPP || omitCheck (ews, outRaw) <- if hasCPP || omitCheck
then return $ pPrintModule moduleConf perItemConf anns parsedSource then return
else liftIO $ pPrintModuleAndCheck moduleConf perItemConf anns parsedSource $ pPrintModule moduleConf perItemConf anns parsedSource
let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s else liftIO $ pPrintModuleAndCheck moduleConf
let out = TextL.toStrict $ if hackAroundIncludes perItemConf
then TextL.intercalate (TextL.pack "\n") $ fmap hackF $ TextL.splitOn (TextL.pack "\n") outRaw 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
@ -285,26 +342,37 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx
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 =
Data.List.Extra.groupOn customErrOrder
$ List.sortOn customErrOrder
$ errsWarns
groupedErrsWarns `forM_` \case groupedErrsWarns `forM_` \case
(ErrorOutputCheck{}:_) -> do (ErrorOutputCheck{} : _) -> do
putErrorLn $ "ERROR: brittany pretty printer" ++ " returned syntactically invalid result." putErrorLn
(ErrorInput str:_) -> do $ "ERROR: brittany pretty printer"
++ " returned syntactically invalid result."
(ErrorInput str : _) -> do
putErrorLn $ "ERROR: parse error: " ++ str putErrorLn $ "ERROR: parse error: " ++ str
uns@(ErrorUnknownNode{}:_) -> do uns@(ErrorUnknownNode{} : _) -> do
putErrorLn $ "ERROR: encountered unknown syntactical constructs:" putErrorLn $ "ERROR: encountered unknown syntactical constructs:"
uns `forM_` \case uns `forM_` \case
ErrorUnknownNode str ast -> do ErrorUnknownNode str ast -> do
putErrorLn str putErrorLn str
when (config & _conf_debug & _dconf_dump_ast_unknown & confUnpack) $ do when
( config
& _conf_debug
& _dconf_dump_ast_unknown
& confUnpack
)
$ do
putErrorLn $ " " ++ show (astToDoc ast) putErrorLn $ " " ++ show (astToDoc ast)
_ -> error "cannot happen (TM)" _ -> error "cannot happen (TM)"
warns@(LayoutWarning{}:_) -> do warns@(LayoutWarning{} : _) -> do
putErrorLn $ "WARNINGS:" putErrorLn $ "WARNINGS:"
warns `forM_` \case warns `forM_` \case
LayoutWarning str -> putErrorLn str LayoutWarning str -> putErrorLn str
_ -> error "cannot happen (TM)" _ -> error "cannot happen (TM)"
unused@(ErrorUnusedComment{}:_) -> do unused@(ErrorUnusedComment{} : _) -> do
putErrorLn putErrorLn
$ "Error: detected unprocessed comments." $ "Error: detected unprocessed comments."
++ " The transformation output will most likely" ++ " The transformation output will most likely"
@ -314,21 +382,28 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx
unused `forM_` \case unused `forM_` \case
ErrorUnusedComment str -> putErrorLn str ErrorUnusedComment str -> putErrorLn str
_ -> error "cannot happen (TM)" _ -> error "cannot happen (TM)"
(ErrorMacroConfig err input:_) -> do (ErrorMacroConfig err input : _) -> do
putErrorLn putErrorLn $ "Error: parse error in inline configuration:"
$ "Error: parse error in inline configuration:"
putErrorLn err putErrorLn err
putErrorLn $ " in the string \"" ++ input ++ "\"." putErrorLn $ " in the string \"" ++ input ++ "\"."
[] -> error "cannot happen" [] -> error "cannot happen"
-- TODO: don't output anything when there are errors unless user -- TODO: don't output anything when there are errors unless user
-- adds some override? -- adds some override?
let hasErrors = case config & _conf_errorHandling & _econf_Werror & confUnpack of let
hasErrors =
case config & _conf_errorHandling & _econf_Werror & confUnpack of
False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) False -> 0 < maximum (-1 : fmap customErrOrder errsWarns)
True -> not $ null errsWarns True -> not $ null errsWarns
outputOnErrs = config & _conf_errorHandling & _econf_produceOutputOnErrors & confUnpack 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
$ addTraceSep (_conf_debug config)
$ case outputPathM of
Nothing -> liftIO $ Text.IO.putStr $ outSText Nothing -> liftIO $ Text.IO.putStr $ outSText
Just p -> liftIO $ do Just p -> liftIO $ do
isIdentical <- case inputPathM of isIdentical <- case inputPathM of
@ -340,8 +415,8 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx
-- read. Should be in cache still anyways. -- read. Should be in cache still anyways.
-- --
-- We do not use TextL.IO.readFile because lazy IO is evil. -- We do not use TextL.IO.readFile because lazy IO is evil.
-- (not identical -> read is not finished -> handle still open -> -- (not identical -> read is not finished ->
-- write below crashes - evil.) -- handle still open -> write below crashes - evil.)
unless isIdentical $ Text.IO.writeFile p $ outSText unless isIdentical $ Text.IO.writeFile p $ outSText
when hasErrors $ ExceptT.throwE 70 when hasErrors $ ExceptT.throwE 70

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

@ -17,6 +17,7 @@ where
#include "prelude.inc" #include "prelude.inc"
-- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 }
import qualified Language.Haskell.GHC.ExactPrint 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.Types as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers
@ -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
hiding ( parseModule )
import ApiAnnotation ( AnnKeywordId(..) ) import ApiAnnotation ( AnnKeywordId(..) )
import GHC ( runGhc, GenLocated(L), moduleNameString ) import GHC ( runGhc
, GenLocated(L)
, moduleNameString
)
import SrcLoc ( SrcSpan ) 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,8 +309,7 @@ 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
@ -318,15 +323,12 @@ pPrintModule conf inlineConf anns parsedModule =
traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations
$ annsDoc anns $ annsDoc anns
ppModule parsedModule ppModule parsedModule
tracer = tracer = if Seq.null debugStrings
if Seq.null debugStrings then id
then
id
else else
trace ("---- DEBUGMESSAGES ---- ") trace ("---- DEBUGMESSAGES ---- ")
. foldr (seq . join trace) id debugStrings . foldr (seq . join trace) id debugStrings
in in tracer $ (errs, Text.Builder.toLazyText out)
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
@ -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
@ -491,7 +494,8 @@ getDeclBindingNames (L _ decl) = case decl of
-- 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
:: GenLocated SrcSpan (HsModule GhcPs)
-> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] -> 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 ->
@ -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
>>= briDocToDoc
.> traceIfDumpConf "bridoc post-floating"
_dconf_dump_bridoc_simpl_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 $ ()