From 6725d0e1198aa490cf482e3dcf75dffb5c682471 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 4 Jun 2018 17:06:23 +0200 Subject: [PATCH] Refactor/Auto-format Main, Brittany.Internal --- src-brittany/Main.hs | 427 +++++++++++++--------- src/Language/Haskell/Brittany/Internal.hs | 135 +++---- 2 files changed, 324 insertions(+), 238 deletions(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 3652d47..68f846a 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 182f3ed..dd07051 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -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 $ ()