From 18704e403f6164aab15e7036d07ecbf27dea8c47 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 19 Apr 2018 17:03:59 +0200 Subject: [PATCH] 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.