diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index ff59b4c..c064441 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -343,11 +343,16 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = 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 disableFormatting = + moduleConf & _conf_disable_formatting & confUnpack + (errsWarns, outSText, hasChanges) <- do + if + | disableFormatting -> do + pure ([], originalContents, False) + | exactprintOnly -> do + let r = Text.pack $ ExactPrint.exactPrint parsedSource anns + pure ([], r, r /= originalContents) + | otherwise -> do let omitCheck = moduleConf & _conf_errorHandling @@ -372,7 +377,7 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = out' <- if moduleConf & _conf_obfuscate & confUnpack then lift $ obfuscate out else pure out - pure $ (ews, out') + pure $ (ews, out', out' /= originalContents) let customErrOrder ErrorInput{} = 4 customErrOrder LayoutWarning{} = -1 :: Int customErrOrder ErrorOutputCheck{} = 1 @@ -440,7 +445,6 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = & confUnpack shouldOutput = not suppressOutput && (not hasErrors || outputOnErrs) - let noChanges = outSText == originalContents when shouldOutput $ addTraceSep (_conf_debug config) $ case outputPathM of @@ -448,11 +452,11 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = Just p -> liftIO $ do let isIdentical = case inputPathM of Nothing -> False - Just _ -> noChanges + Just _ -> not hasChanges unless isIdentical $ Text.IO.writeFile p $ outSText when hasErrors $ ExceptT.throwE 70 - return (if noChanges then NoChanges else Changes) + return (if hasChanges then Changes else NoChanges) where addTraceSep conf = if or diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 3595b1f..19e940a 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -220,6 +220,7 @@ defaultTestConfig = Config , _conf_preprocessor = _conf_preprocessor staticDefaultConfig , _conf_forward = ForwardOptions { _options_ghc = Identity [] } , _conf_roundtrip_exactprint_only = coerce False + , _conf_disable_formatting = coerce False , _conf_obfuscate = coerce False } diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index 3f24266..2e53f67 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -69,5 +69,6 @@ defaultTestConfig = Config , _conf_preprocessor = (_conf_preprocessor staticDefaultConfig) , _conf_forward = ForwardOptions {_options_ghc = Identity []} , _conf_roundtrip_exactprint_only = coerce False + , _conf_disable_formatting = coerce False , _conf_obfuscate = coerce False } diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 2bc91ba..7033354 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -160,6 +160,12 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do Butcher.addCmd "-disable-next-declaration" disableNextDecl Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl + let disableFormatting = do + Butcher.addCmdImpl + ( InlineConfigTargetModule + , mempty { _conf_disable_formatting = pure $ pure True } + ) + Butcher.addCmd "-disable" disableFormatting Butcher.addCmd "@" $ do -- Butcher.addCmd "module" $ do -- conf <- configParser @@ -266,38 +272,47 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do (inlineConf, perItemConf) <- either (throwE . (: []) . uncurry ErrorMacroConfig) pure $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) - let moduleConfig = cZipWith fromOptionIdentity config inlineConf - (errsWarns, outputTextL) <- do - let omitCheck = - moduleConfig - & _conf_errorHandling - & _econf_omit_output_valid_check - & confUnpack - (ews, outRaw) <- if hasCPP || omitCheck - then return $ pPrintModule 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 - then - ( ews - , TextL.intercalate (TextL.pack "\n") $ fmap hackF $ TextL.splitOn - (TextL.pack "\n") - outRaw - ) - else (ews, outRaw) - let customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = 0 :: Int - customErrOrder ErrorOutputCheck{} = 1 - customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = 3 - customErrOrder ErrorMacroConfig{} = 5 - let hasErrors = - case moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack of - False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) - True -> not $ null errsWarns - if hasErrors then throwE $ errsWarns else pure $ TextL.toStrict outputTextL + let moduleConfig = cZipWith fromOptionIdentity config inlineConf + let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack + if disableFormatting + then do + return inputText + else do + (errsWarns, outputTextL) <- do + let omitCheck = + moduleConfig + & _conf_errorHandling + & _econf_omit_output_valid_check + & confUnpack + (ews, outRaw) <- if hasCPP || omitCheck + then return $ pPrintModule 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 + then + ( ews + , TextL.intercalate (TextL.pack "\n") $ fmap hackF $ TextL.splitOn + (TextL.pack "\n") + outRaw + ) + else (ews, outRaw) + let customErrOrder ErrorInput{} = 4 + customErrOrder LayoutWarning{} = 0 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnknownNode{} = 3 + customErrOrder ErrorMacroConfig{} = 5 + let hasErrors = + case + moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack + of + False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) + True -> not $ null errsWarns + if hasErrors + then throwE $ errsWarns + else pure $ TextL.toStrict outputTextL @@ -459,6 +474,7 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack + when exactprintOnly $ mTell $ Text.Builder.fromText $ Text.pack "abc" toLocal config' filteredAnns $ do bd <- if exactprintOnly then briDocMToPPM $ briDocByExactNoComment decl diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index a5bbdbd..fc2e8cc 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -93,6 +93,7 @@ staticDefaultConfig = Config { _options_ghc = Identity [] } , _conf_roundtrip_exactprint_only = coerce False + , _conf_disable_formatting = coerce False , _conf_obfuscate = coerce False } @@ -147,6 +148,7 @@ cmdlineConfigParser = do ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.") + disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.") obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.") return $ Config @@ -198,6 +200,7 @@ cmdlineConfigParser = do { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly + , _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting , _conf_obfuscate = wrapLast $ falseToNothing obfuscate } where diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index a244eae..32da0ac 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -187,11 +187,17 @@ data CConfig f = Config , _conf_forward :: CForwardOptions f , _conf_preprocessor :: CPreProcessorConfig f , _conf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) - , _conf_obfuscate :: 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. + , _conf_disable_formatting :: f (Semigroup.Last Bool) + -- ^ Used for inline config that disables brittany entirely for this + -- module. Useful for wildcard application + -- (`find -name "*.hs" | xargs brittany --write-mode inplace` or something + -- in that direction). + , _conf_obfuscate :: f (Semigroup.Last Bool) + } 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 82edaed..74dfe0e 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs @@ -120,6 +120,7 @@ instance FromJSON (CConfig Maybe) where <*> v .:?= Text.pack "conf_forward" <*> v .:?= Text.pack "conf_preprocessor" <*> v .:? Text.pack "conf_roundtrip_exactprint_only" + <*> v .:? Text.pack "conf_disable_formatting" <*> v .:? Text.pack "conf_obfuscate" parseJSON invalid = Aeson.typeMismatch "Config" invalid