From e559a2cbf71d58b8f1c1fe868680004cb8a54506 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 1 Oct 2017 16:16:43 +0200 Subject: [PATCH 1/5] Implement inline configuration e.g. "-- brittany --indent=4" respects the following comment forms as input: source comment affected target ====================================================== "-- brittany CONFIG" whole module "-- brittany-next-binding CONFIG" next binding "-- brittany-disable-next-binding" next binding "-- brittany @ myExampleFunc CONFIG" `myExampleFunc` multiline-comments are supported too, although the specification must still be a single line. E.g. "{- brittany --columns 50 -}" CONFIG is either: 1) one or more flags in the form of what brittany accepts on the commandline, e.g. "-- columns 50", or 2) one or more specifications in the form of what brittany accepts in its config files for the layouting config (a one-line yaml document), e.g. "{ lconfig_cols: 50 }" see #30 --- brittany.cabal | 3 +- src-brittany/Main.hs | 31 +- src/Language/Haskell/Brittany/Internal.hs | 285 +++++++++++++++--- .../Haskell/Brittany/Internal/Config.hs | 6 +- .../Haskell/Brittany/Internal/Config/Types.hs | 10 + .../Haskell/Brittany/Internal/PreludeUtils.hs | 13 +- .../Haskell/Brittany/Internal/Types.hs | 17 +- 7 files changed, 303 insertions(+), 62 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index bee2b04..4d99213 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -80,6 +80,7 @@ library { -Wall -fno-warn-unused-imports -fno-warn-redundant-constraints + -j } build-depends: { base >=4.9 && <4.11 @@ -97,7 +98,7 @@ library { , pretty >=1.1.3.3 && <1.2 , bytestring >=0.10.8.1 && <0.11 , directory >=1.2.6.2 && <1.4 - , butcher >=1.3 && <1.4 + , butcher >=1.3.1 && <1.4 , yaml >=0.8.18 && <0.9 , aeson >=1.0.1.0 && <1.3 , extra >=1.4.10 && <1.7 diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index fed179b..ff7fedc 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -133,7 +133,7 @@ mainCmdParser helpDesc = do printVersion <- addSimpleBoolFlag "" ["version"] mempty printLicense <- addSimpleBoolFlag "" ["license"] mempty configPaths <- addFlagStringParams "" ["config-file"] "PATH" (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? - cmdlineConfig <- configParser + cmdlineConfig <- cmdlineConfigParser suppressOutput <- addSimpleBoolFlag "" ["suppress-output"] @@ -179,7 +179,7 @@ mainCmdParser helpDesc = do config <- runMaybeT (readConfigsWithUserConfig cmdlineConfig configsToLoad) >>= \case Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) Just x -> return x - when (confUnpack $ _dconf_dump_config $ _conf_debug $ config) $ + when (config & _conf_debug & _dconf_dump_config & confUnpack) $ trace (showConfigYaml config) $ return () results <- zipWithM (coreIO putStrErrLn config suppressOutput) inputPaths outputPaths @@ -211,9 +211,11 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx -- 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 - -- ("-- BRITTANY_INCLUDE_HACK ") right before any lines starting with + -- ("-- 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_debug & _dconf_roundtrip_exactprint_only & confUnpack let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags @@ -232,7 +234,7 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx 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 "-- BRITTANY_INCLUDE_HACK " ++ s else s + 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 @@ -244,6 +246,15 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx putErrorLn $ show left ExceptT.throwE 60 Right (anns, parsedSource, hasCPP) -> do + inlineConf <- 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 when (config & _conf_debug .> _dconf_dump_ast_full .> confUnpack) $ do let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource trace ("---- ast ----\n" ++ show val) $ return () @@ -254,9 +265,9 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx else do let omitCheck = config & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack (ews, outRaw) <- if hasCPP || omitCheck - then return $ pPrintModule config anns parsedSource - else liftIO $ pPrintModuleAndCheck config anns parsedSource - let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITTANY_INCLUDE_HACK ") s + then return $ pPrintModule config inlineConf anns parsedSource + else liftIO $ pPrintModuleAndCheck config inlineConf 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 @@ -266,6 +277,7 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx 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 @@ -296,6 +308,11 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx 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? diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index e6a3c72..b4a4525 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -8,6 +8,8 @@ module Language.Haskell.Brittany.Internal -- re-export from utils: , parseModule , parseModuleFromString + , extractCommentConfigs + , getTopLevelDeclNameMap ) where @@ -22,7 +24,10 @@ import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers import Data.Data import Control.Monad.Trans.Except 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 Data.Text.Lazy.Builder as Text.Builder @@ -54,6 +59,170 @@ import HsSyn import qualified DynFlags as GHC import qualified GHC.LanguageExtensions.Type as GHC +import Data.Char (isSpace) + + + +data InlineConfigTarget + = InlineConfigTargetModule + | InlineConfigTargetNextDecl -- really only next in module + | InlineConfigTargetNextBinding -- by name + | InlineConfigTargetBinding String + +extractCommentConfigs + :: ExactPrint.Anns + -> TopLevelDeclNameMap + -> Either (String, String) InlineConfig +extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do + let + commentLiness = + [ ( k + , [ x + | (ExactPrint.Comment x _ _, _) <- + ( ExactPrint.annPriorComments ann + ++ ExactPrint.annFollowingComments ann + ) + ] + ++ [ x + | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <- + ExactPrint.annsDP ann + ] + ) + | (k, ann) <- Map.toList anns + ] + let configLiness = commentLiness <&> second + (Data.Maybe.mapMaybe $ \line -> do + l1 <- + List.stripPrefix "-- BRITTANY" line + <|> List.stripPrefix "--BRITTANY" line + <|> List.stripPrefix "-- brittany" line + <|> List.stripPrefix "--brittany" line + <|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}") + let l2 = dropWhile isSpace l1 + guard + ( ("@" `isPrefixOf` l2) + || ("-disable" `isPrefixOf` l2) + || ("-next" `isPrefixOf` l2) + || ("{" `isPrefixOf` l2) + || ("--" `isPrefixOf` l2) + ) + pure l2 + ) + let + configParser = Butcher.addAlternatives + [ ( "commandline-config" + , \s -> "-" `isPrefixOf` dropWhile (== ' ') s + , cmdlineConfigParser + ) + , ( "yaml-config-document" + , \s -> "{" `isPrefixOf` dropWhile (== ' ') s + , Butcher.addCmdPart (Butcher.varPartDesc "yaml-config-document") + $ fmap (\lconf -> (mempty { _conf_layout = lconf }, "")) + . Data.Yaml.decode + . Data.ByteString.Char8.pack + -- TODO: use some proper utf8 encoder instead? + ) + ] + parser = do -- we will (mis?)use butcher here to parse the inline config + -- line. + let nextDecl = do + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf) + Butcher.addCmd "-next-declaration" nextDecl + Butcher.addCmd "-Next-Declaration" nextDecl + Butcher.addCmd "-NEXT-DECLARATION" nextDecl + let nextBinding = do + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf) + Butcher.addCmd "-next-binding" nextBinding + Butcher.addCmd "-Next-Binding" nextBinding + Butcher.addCmd "-NEXT-BINDING" nextBinding + let + disableNextBinding = do + Butcher.addCmdImpl + ( InlineConfigTargetNextBinding + , mempty + { _conf_debug = + mempty { _dconf_roundtrip_exactprint_only = pure $ pure True } + } + ) + Butcher.addCmd "-disable-next-binding" disableNextBinding + Butcher.addCmd "-Disable-Next-Binding" disableNextBinding + Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding + let + disableNextDecl = do + Butcher.addCmdImpl + ( InlineConfigTargetNextDecl + , mempty + { _conf_debug = + mempty { _dconf_roundtrip_exactprint_only = pure $ pure True } + } + ) + Butcher.addCmd "-disable-next-declaration" disableNextDecl + Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl + Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl + Butcher.addCmd "@" $ do + -- Butcher.addCmd "module" $ do + -- conf <- configParser + -- Butcher.addCmdImpl (InlineConfigTargetModule, conf) + Butcher.addNullCmd $ do + bindingName <- Butcher.addParamString "BINDING" mempty + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetBinding bindingName, conf) + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetModule, conf) + lineConfigss <- configLiness `forM` \(k, ss) -> do + r <- ss `forM` \s -> case Butcher.runCmdParserSimple s parser of + Left err -> Left $ (err, s) + Right c -> Right $ c + pure (k, r) + + let perModule = foldl' + (<>) + mempty + [ conf + | (_ , lineConfigs) <- lineConfigss + , (InlineConfigTargetModule, conf ) <- lineConfigs + ] + let + perBinding = Map.fromListWith + (<>) + [ (n, conf) + | (k , lineConfigs) <- lineConfigss + , (target, conf ) <- lineConfigs + , n <- case target of + InlineConfigTargetBinding s -> [s] + InlineConfigTargetNextBinding | Just name <- Map.lookup k declNameMap -> + [name] + _ -> [] + ] + let + perKey = Map.fromListWith + (<>) + [ (k, conf) + | (k , lineConfigs) <- lineConfigss + , (target, conf ) <- lineConfigs + , case target of + InlineConfigTargetNextDecl -> True + InlineConfigTargetNextBinding | Nothing <- Map.lookup k declNameMap -> + True + _ -> False + ] + + pure $ InlineConfig + { _icd_perModule = perModule + , _icd_perBinding = perBinding + , _icd_perKey = perKey + } + + +getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap +getTopLevelDeclNameMap (L _ (HsModule _name _exports _ decls _ _)) = + TopLevelDeclNameMap $ Map.fromList + [ (ExactPrint.mkAnnKey decl, name) + | decl <- decls + , (name : _) <- [getDeclBindingNames decl] + ] -- | Exposes the transformation in an pseudo-pure fashion. The signature @@ -68,15 +237,16 @@ import qualified GHC.LanguageExtensions.Type as GHC -- may wish to put some proper upper bound on the input's size as a timeout -- won't do. parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text) -parsePrintModule configRaw inputText = runExceptT $ do - let config = configRaw { _conf_debug = _conf_debug staticDefaultConfig } +parsePrintModule configWithDebugs inputText = runExceptT $ do + let config = + configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig } let ghcOptions = config & _conf_forward & _options_ghc & runIdentity let config_pp = config & _conf_preprocessor let cppMode = config_pp & _ppconf_CPPMode & confUnpack let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack (anns, parsedSource, hasCPP) <- do let hackF s = if "#include" `isPrefixOf` s - then "-- BRITTANY_INCLUDE_HACK " ++ s + then "-- BRITANY_INCLUDE_HACK " ++ s else s let hackTransform = if hackAroundIncludes then List.intercalate "\n" . fmap hackF . lines' @@ -95,6 +265,8 @@ parsePrintModule configRaw inputText = runExceptT $ do case parseResult of Left err -> throwE [ErrorInput err] Right x -> pure x + inlineConf <- either (throwE . (: []) . uncurry ErrorMacroConfig) pure + $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) (errsWarns, outputTextL) <- do let omitCheck = config @@ -102,10 +274,10 @@ parsePrintModule configRaw inputText = runExceptT $ do & _econf_omit_output_valid_check & confUnpack (ews, outRaw) <- if hasCPP || omitCheck - then return $ pPrintModule config anns parsedSource - else lift $ pPrintModuleAndCheck config anns parsedSource + then return $ pPrintModule config inlineConf anns parsedSource + else lift $ pPrintModuleAndCheck config inlineConf anns parsedSource let hackF s = fromMaybe s - $ TextL.stripPrefix (TextL.pack "-- BRITTANY_INCLUDE_HACK ") s + $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s pure $ if hackAroundIncludes then ( ews @@ -119,6 +291,7 @@ parsePrintModule configRaw inputText = runExceptT $ do customErrOrder ErrorOutputCheck{} = 1 customErrOrder ErrorUnusedComment{} = 2 customErrOrder ErrorUnknownNode{} = 3 + customErrOrder ErrorMacroConfig{} = 5 let hasErrors = case config & _conf_errorHandling & _econf_Werror & confUnpack of False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) @@ -133,10 +306,11 @@ parsePrintModule configRaw inputText = runExceptT $ do -- can occur. pPrintModule :: Config + -> InlineConfig -> ExactPrint.Anns -> GHC.ParsedSource -> ([BrittanyError], TextL.Text) -pPrintModule conf anns parsedModule = +pPrintModule conf inlineConf anns parsedModule = let ((out, errs), debugStrings) = runIdentity @@ -146,6 +320,7 @@ pPrintModule conf anns parsedModule = $ MultiRWSS.withMultiWriterW $ MultiRWSS.withMultiReader anns $ MultiRWSS.withMultiReader conf + $ MultiRWSS.withMultiReader inlineConf $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) $ do traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations @@ -169,12 +344,13 @@ pPrintModule conf anns parsedModule = -- if it does not. pPrintModuleAndCheck :: Config + -> InlineConfig -> ExactPrint.Anns -> GHC.ParsedSource -> IO ([BrittanyError], TextL.Text) -pPrintModuleAndCheck conf anns parsedModule = do +pPrintModuleAndCheck conf inlineConf anns parsedModule = do let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity - let (errs, output) = pPrintModule conf anns parsedModule + let (errs, output) = pPrintModule conf inlineConf anns parsedModule parseResult <- parseModuleFromString ghcOptions "output" (\_ -> return $ Right ()) @@ -193,28 +369,34 @@ parsePrintModuleTests conf filename input = do parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr case parseResult of Left (_ , s ) -> return $ Left $ "parsing error: " ++ s - Right (anns, parsedModule) -> do + Right (anns, parsedModule) -> runExceptT $ do + inlineConf <- + case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of + Left err -> throwE $ "error in inline config: " ++ show err + Right x -> pure x let omitCheck = conf & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack (errs, ltext) <- if omitCheck - then return $ pPrintModule conf anns parsedModule - else pPrintModuleAndCheck conf anns parsedModule - return $ if null errs - then Right $ TextL.toStrict $ ltext + then return $ pPrintModule conf inlineConf anns parsedModule + else lift $ pPrintModuleAndCheck conf inlineConf anns parsedModule + if null errs + then pure $ TextL.toStrict $ ltext else - let errStrs = errs <&> \case - ErrorInput str -> str - ErrorUnusedComment str -> str - LayoutWarning str -> str - ErrorUnknownNode str _ -> str - ErrorOutputCheck -> "Output is not syntactically valid." - in Left $ "pretty printing error(s):\n" ++ List.unlines errStrs + let + errStrs = errs <&> \case + ErrorInput str -> str + ErrorUnusedComment str -> str + LayoutWarning str -> str + ErrorUnknownNode str _ -> str + ErrorMacroConfig str _ -> "when parsing inline config: " ++ str + ErrorOutputCheck -> "Output is not syntactically valid." + in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs --- this approach would for with there was a pure GHC.parseDynamicFilePragma. +-- this approach would for if there was a pure GHC.parseDynamicFilePragma. -- Unfortunately that does not exist yet, so we cannot provide a nominally -- pure interface. @@ -248,12 +430,25 @@ parsePrintModuleTests conf filename input = do -- Left $ "pretty printing error(s):\n" ++ List.unlines errStrs -- else return $ TextL.toStrict $ Text.Builder.toLazyText out +toLocal :: Config -> ExactPrint.Anns -> PPMLocal a -> PPM a +toLocal conf anns m = do + (x, write) <- lift $ MultiRWSS.runMultiRWSTAW (conf :+: anns :+: HNil) HNil $ m + MultiRWSS.mGetRawW >>= \w -> MultiRWSS.mPutRawW (w <> write) + pure x + ppModule :: GenLocated SrcSpan (HsModule RdrName) -> PPM () ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do post <- ppPreamble lmod decls `forM_` \decl -> do - filteredAnns <- mAsk <&> \annMap -> - Map.findWithDefault Map.empty (ExactPrint.mkAnnKey decl) annMap + let declAnnKey = ExactPrint.mkAnnKey decl + let declBindingNames = getDeclBindingNames decl + inlineConf <- mAsk + let inlineModConf = _icd_perModule inlineConf + let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf + let mBindingConfs = + declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf + filteredAnns <- mAsk + <&> \annMap -> Map.findWithDefault Map.empty declAnnKey annMap traceIfDumpConf "bridoc annotations filtered/transformed" _dconf_dump_annotations @@ -261,13 +456,14 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do config <- mAsk - MultiRWSS.withoutMultiReader $ do - MultiRWSS.mPutRawR $ config :+: filteredAnns :+: HNil - ppDecl decl + let config' = cZipWith fromOptionIdentity config $ mconcat + (inlineModConf : (catMaybes (mBindingConfs ++ [mDeclConf]))) + + toLocal config' filteredAnns $ ppDecl decl let finalComments = filter - ( fst .> \case + (fst .> \case ExactPrint.AnnComment{} -> True - _ -> False + _ -> False ) post post `forM_` \case @@ -275,17 +471,15 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do ppmMoveToExactLoc l mTell $ Text.Builder.fromString cmStr (ExactPrint.G AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> - let - folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of - ExactPrint.AnnComment cm - | GHC.RealSrcSpan span <- ExactPrint.commentIdentifier cm - -> ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span - , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span - ) - _ -> (acc + y, x) - (cmY, cmX) = foldl' folder (0, 0) finalComments - in - ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) + let folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of + ExactPrint.AnnComment cm + | GHC.RealSrcSpan span <- ExactPrint.commentIdentifier cm + -> ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span + , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span + ) + _ -> (acc + y, x) + (cmY, cmX) = foldl' folder (0, 0) finalComments + in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) _ -> return () withTransformedAnns :: Data ast => ast -> PPMLocal () -> PPMLocal () @@ -302,6 +496,13 @@ withTransformedAnns ast m = do in annsBalanced +getDeclBindingNames :: LHsDecl RdrName -> [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] + _ -> [] + + ppDecl :: LHsDecl RdrName -> PPMLocal () ppDecl d@(L loc decl) = case decl of SigD sig -> -- trace (_sigHead sig) $ @@ -380,9 +581,7 @@ ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do $ annsDoc filteredAnns' if shouldReformatPreamble - then MultiRWSS.withoutMultiReader $ do - MultiRWSS.mPutRawR $ config :+: filteredAnns' :+: HNil - withTransformedAnns lmod $ do + then toLocal config filteredAnns' $ withTransformedAnns lmod $ do briDoc <- briDocMToPPM $ layoutModule lmod layoutBriDoc briDoc else diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index 76e9c95..6e87813 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -5,7 +5,7 @@ module Language.Haskell.Brittany.Internal.Config , DebugConfig , LayoutConfig , Config - , configParser + , cmdlineConfigParser , staticDefaultConfig , forwardOptionsSyntaxExtsEnabled , readConfig @@ -108,8 +108,8 @@ forwardOptionsSyntaxExtsEnabled = ForwardOptions ] } -configParser :: CmdParser Identity out (CConfig Option) -configParser = do +cmdlineConfigParser :: CmdParser Identity out (CConfig Option) +cmdlineConfigParser = do -- TODO: why does the default not trigger; ind never should be []!! ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level") cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)") diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index d28527d..1da457e 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -176,6 +176,16 @@ deriving instance Data (CForwardOptions Identity) deriving instance Data (CPreProcessorConfig Identity) deriving instance Data (CConfig Identity) +#if MIN_VERSION_ghc(8,2,0) +-- these instances break on earlier ghcs +deriving instance Data (CDebugConfig Option) +deriving instance Data (CLayoutConfig Option) +deriving instance Data (CErrorHandlingConfig Option) +deriving instance Data (CForwardOptions Option) +deriving instance Data (CPreProcessorConfig Option) +deriving instance Data (CConfig Option) +#endif + instance Semigroup.Semigroup (CDebugConfig Option) where (<>) = gmappend instance Semigroup.Semigroup (CLayoutConfig Option) where diff --git a/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs b/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs index 88f2894..df80168 100644 --- a/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs @@ -32,13 +32,12 @@ instance Alternative Strict.Maybe where x <|> Strict.Nothing = x _ <|> x = x -traceFunctionWith - :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b) -traceFunctionWith name s1 s2 f x = - trace traceStr y - where - y = f x - traceStr = name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y +traceFunctionWith :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b) +traceFunctionWith name s1 s2 f x = trace traceStr y + where + y = f x + traceStr = + name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y (<&!>) :: Monad m => m a -> (a -> b) -> m b (<&!>) = flip (<$!>) diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index 1d26b73..a0716da 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -13,6 +13,7 @@ where #include "prelude.inc" import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Data.Text.Lazy.Builder as Text.Builder @@ -28,8 +29,17 @@ import Data.Generics.Uniplate.Direct as Uniplate +data InlineConfig = InlineConfig + { _icd_perModule :: CConfig Option + , _icd_perBinding :: Map String (CConfig Option) + , _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Option) + } +#if MIN_VERSION_ghc(8,2,0) + deriving Data.Data.Data +#endif + type PPM = MultiRWSS.MultiRWS - '[Map ExactPrint.AnnKey ExactPrint.Anns, Config, ExactPrint.Anns] + '[Map ExactPrint.AnnKey ExactPrint.Anns, InlineConfig, Config, ExactPrint.Anns] '[Text.Builder.Builder, [BrittanyError], Seq String] '[] @@ -38,6 +48,8 @@ type PPMLocal = MultiRWSS.MultiRWS '[Text.Builder.Builder, [BrittanyError], Seq String] '[] +newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map ExactPrint.AnnKey String) + data LayoutState = LayoutState { _lstate_baseYs :: [Int] -- ^ stack of number of current indentation columns @@ -119,6 +131,9 @@ data BrittanyError -- ^ parsing failed | ErrorUnusedComment String -- ^ internal error: some comment went missing + | ErrorMacroConfig String String + -- ^ in-source config string parsing error; first argument is the parser + -- output and second the corresponding, ill-formed input. | LayoutWarning String -- ^ some warning | forall ast . Data.Data.Data ast => ErrorUnknownNode String ast -- 2.30.2 From 2a8a752a595b6cac51dad2130ba17720f5be2044 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 17 Apr 2018 19:52:22 +0200 Subject: [PATCH 2/5] Fix stack.yamls --- stack-8.0.2.yaml | 2 +- stack-8.2.2.yaml | 1 + stack.yaml | 1 + 3 files changed, 3 insertions(+), 1 deletion(-) diff --git a/stack-8.0.2.yaml b/stack-8.0.2.yaml index 4f20ca7..bdf7c39 100644 --- a/stack-8.0.2.yaml +++ b/stack-8.0.2.yaml @@ -3,7 +3,7 @@ resolver: lts-9.0 extra-deps: - monad-memo-0.4.1 - czipwith-1.0.1.0 - - butcher-1.3.0.0 + - butcher-1.3.1.0 - data-tree-print-0.1.0.0 - deque-0.2 - ghc-exactprint-0.5.6.0 diff --git a/stack-8.2.2.yaml b/stack-8.2.2.yaml index 899363f..cbeba2e 100644 --- a/stack-8.2.2.yaml +++ b/stack-8.2.2.yaml @@ -2,6 +2,7 @@ resolver: lts-11.1 extra-deps: - czipwith-1.0.1.0 + - butcher-1.3.1.0 packages: - . diff --git a/stack.yaml b/stack.yaml index 899363f..cbeba2e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,6 +2,7 @@ resolver: lts-11.1 extra-deps: - czipwith-1.0.1.0 + - butcher-1.3.1.0 packages: - . -- 2.30.2 From 17fb271694d5d2936564776f804918fabf1cb730 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 17 Apr 2018 20:34:11 +0200 Subject: [PATCH 3/5] Fix inlineconfig additions for ghc-8.4 + compat The semigroup changes are a bit confusing when aiming for backwards-compat. --- src/Language/Haskell/Brittany/Internal.hs | 4 ++-- stack-8.0.2.yaml | 2 +- stack-8.2.2.yaml | 2 +- stack.yaml | 2 +- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index d839fa3..7e73081 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -432,7 +432,7 @@ 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 - MultiRWSS.mGetRawW >>= \w -> MultiRWSS.mPutRawW (w <> write) + MultiRWSS.mGetRawW >>= \w -> MultiRWSS.mPutRawW (w `mappend` write) pure x ppModule :: GenLocated SrcSpan (HsModule GhcPs) -> PPM () @@ -495,7 +495,7 @@ withTransformedAnns ast m = do in annsBalanced -getDeclBindingNames :: LHsDecl RdrName -> [String] +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] diff --git a/stack-8.0.2.yaml b/stack-8.0.2.yaml index bdf7c39..849e301 100644 --- a/stack-8.0.2.yaml +++ b/stack-8.0.2.yaml @@ -3,7 +3,7 @@ resolver: lts-9.0 extra-deps: - monad-memo-0.4.1 - czipwith-1.0.1.0 - - butcher-1.3.1.0 + - butcher-1.3.1.1 - data-tree-print-0.1.0.0 - deque-0.2 - ghc-exactprint-0.5.6.0 diff --git a/stack-8.2.2.yaml b/stack-8.2.2.yaml index cbeba2e..b7f4c2b 100644 --- a/stack-8.2.2.yaml +++ b/stack-8.2.2.yaml @@ -2,7 +2,7 @@ resolver: lts-11.1 extra-deps: - czipwith-1.0.1.0 - - butcher-1.3.1.0 + - butcher-1.3.1.1 packages: - . diff --git a/stack.yaml b/stack.yaml index cbeba2e..b7f4c2b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,7 +2,7 @@ resolver: lts-11.1 extra-deps: - czipwith-1.0.1.0 - - butcher-1.3.1.0 + - butcher-1.3.1.1 packages: - . -- 2.30.2 From 18704e403f6164aab15e7036d07ecbf27dea8c47 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 19 Apr 2018 17:03:59 +0200 Subject: [PATCH 4/5] Fix inline disabling of brittany --- src-brittany/Main.hs | 3 +- src-literatetests/Main.hs | 15 ++++---- src-unittests/TestUtils.hs | 15 ++++---- src/Language/Haskell/Brittany/Internal.hs | 34 ++++++++----------- .../Haskell/Brittany/Internal/Config.hs | 5 ++- .../Haskell/Brittany/Internal/Config/Types.hs | 5 +++ .../Internal/Config/Types/Instances.hs | 1 + 7 files changed, 41 insertions(+), 37 deletions(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index ff7fedc..3b6f0b2 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -217,7 +217,8 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx -- The flag is intentionally misspelled to prevent clashing with -- inline-config stuff. let hackAroundIncludes = config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack - let exactprintOnly = config & _conf_debug & _dconf_roundtrip_exactprint_only & 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 then case cppMode of CPPModeAbort -> do diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index ebe2a08..42e4c19 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -160,9 +160,9 @@ instance Show PPTextWrapper where defaultTestConfig :: Config defaultTestConfig = Config - { _conf_version = _conf_version staticDefaultConfig - , _conf_debug = _conf_debug staticDefaultConfig - , _conf_layout = LayoutConfig + { _conf_version = _conf_version staticDefaultConfig + , _conf_debug = _conf_debug staticDefaultConfig + , _conf_layout = LayoutConfig { _lconfig_cols = coerce (80 :: Int) , _lconfig_indentPolicy = coerce IndentPolicyFree , _lconfig_indentAmount = coerce (2 :: Int) @@ -178,13 +178,12 @@ defaultTestConfig = Config , _lconfig_reformatModulePreamble = coerce True , _lconfig_allowSingleLineExportList = coerce True } - , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) + , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True } - , _conf_preprocessor = _conf_preprocessor staticDefaultConfig - , _conf_forward = ForwardOptions - { _options_ghc = Identity [] - } + , _conf_preprocessor = _conf_preprocessor staticDefaultConfig + , _conf_forward = ForwardOptions {_options_ghc = Identity []} + , _conf_roundtrip_exactprint_only = coerce True } contextFreeTestConfig :: Config diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index d10f85a..c14b3b8 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -42,9 +42,9 @@ instance Show PPTextWrapper where defaultTestConfig :: Config defaultTestConfig = Config - { _conf_version = _conf_version staticDefaultConfig - , _conf_debug = _conf_debug staticDefaultConfig - , _conf_layout = LayoutConfig + { _conf_version = _conf_version staticDefaultConfig + , _conf_debug = _conf_debug staticDefaultConfig + , _conf_layout = LayoutConfig { _lconfig_cols = coerce (80 :: Int) , _lconfig_indentPolicy = coerce IndentPolicyFree , _lconfig_indentAmount = coerce (2 :: Int) @@ -60,11 +60,10 @@ defaultTestConfig = Config , _lconfig_reformatModulePreamble = coerce True , _lconfig_allowSingleLineExportList = coerce True } - , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) + , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever } - , _conf_preprocessor = (_conf_preprocessor staticDefaultConfig) - , _conf_forward = ForwardOptions - { _options_ghc = Identity [] - } + , _conf_preprocessor = (_conf_preprocessor staticDefaultConfig) + , _conf_forward = ForwardOptions {_options_ghc = Identity []} + , _conf_roundtrip_exactprint_only = coerce False } diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 7e73081..9bc144f 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -136,27 +136,19 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do Butcher.addCmd "-next-binding" nextBinding Butcher.addCmd "-Next-Binding" nextBinding Butcher.addCmd "-NEXT-BINDING" nextBinding - let - disableNextBinding = do - Butcher.addCmdImpl - ( InlineConfigTargetNextBinding - , mempty - { _conf_debug = - mempty { _dconf_roundtrip_exactprint_only = pure $ pure True } - } - ) + let disableNextBinding = do + Butcher.addCmdImpl + ( InlineConfigTargetNextBinding + , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } + ) Butcher.addCmd "-disable-next-binding" disableNextBinding Butcher.addCmd "-Disable-Next-Binding" disableNextBinding Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding - let - disableNextDecl = do - Butcher.addCmdImpl - ( InlineConfigTargetNextDecl - , mempty - { _conf_debug = - mempty { _dconf_roundtrip_exactprint_only = pure $ pure True } - } - ) + let disableNextDecl = do + Butcher.addCmdImpl + ( InlineConfigTargetNextDecl + , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } + ) Butcher.addCmd "-disable-next-declaration" disableNextDecl Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl @@ -458,7 +450,11 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do let config' = cZipWith fromOptionIdentity config $ mconcat (inlineModConf : (catMaybes (mBindingConfs ++ [mDeclConf]))) - toLocal config' filteredAnns $ ppDecl decl + toLocal config' filteredAnns + $ if (config' & _conf_roundtrip_exactprint_only & confUnpack) + then briDocMToPPM (briDocByExactNoComment decl) >>= layoutBriDoc + else ppDecl decl + let finalComments = filter (fst .> \case ExactPrint.AnnComment{} -> True diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index 4c3d312..2891c3d 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -89,6 +89,7 @@ staticDefaultConfig = Config , _conf_forward = ForwardOptions { _options_ghc = Identity [] } + , _conf_roundtrip_exactprint_only = coerce False } forwardOptionsSyntaxExtsEnabled :: ForwardOptions @@ -109,6 +110,7 @@ forwardOptionsSyntaxExtsEnabled = ForwardOptions ] } +-- brittany-next-binding --columns=200 cmdlineConfigParser :: CmdParser Identity out (CConfig Option) cmdlineConfigParser = do -- TODO: why does the default not trigger; ind never should be []!! @@ -156,7 +158,7 @@ cmdlineConfigParser = do , _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns , _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal - , _dconf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly + , _dconf_roundtrip_exactprint_only = mempty } , _conf_layout = LayoutConfig { _lconfig_cols = optionConcat cols @@ -187,6 +189,7 @@ cmdlineConfigParser = do , _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } + , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly } where falseToNothing = Option . Bool.bool Nothing (Just True) diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index 1da457e..91fdb4d 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -145,6 +145,11 @@ data CConfig f = Config , _conf_errorHandling :: CErrorHandlingConfig f , _conf_forward :: CForwardOptions f , _conf_preprocessor :: CPreProcessorConfig f + , _conf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) + -- ^ this field is somewhat of a duplicate of the one in DebugConfig. + -- It is used for per-declaration disabling by the inline config + -- implementation. Could have re-used the existing field, but felt risky + -- to use a "debug" labeled field for non-debug functionality. } deriving (Generic) diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs index 5f9f781..6f879b4 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs @@ -119,6 +119,7 @@ instance FromJSON (CConfig Maybe) where <*> v .:?= Text.pack "conf_errorHandling" <*> v .:?= Text.pack "conf_forward" <*> v .:?= Text.pack "conf_preprocessor" + <*> v .:? Text.pack "conf_roundtrip_exactprint_only" parseJSON invalid = Aeson.typeMismatch "Config" invalid -- Pretends that the value is {} when the key is not present. -- 2.30.2 From 280b70f6bdb4674c3386abedad38af797af31ddf Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 19 Apr 2018 18:08:07 +0200 Subject: [PATCH 5/5] Undo adding -j ghc-option in brittany.cabal --- brittany.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/brittany.cabal b/brittany.cabal index 0d172c8..5c76137 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -80,7 +80,6 @@ library { -Wall -fno-warn-unused-imports -fno-warn-redundant-constraints - -j } build-depends: { base >=4.9 && <4.12 -- 2.30.2