{-# LANGUAGE NoImplicitPrelude #-} module Language.Haskell.Brittany.Internal ( Parsing.parseModule , Parsing.parseModuleFromString , parsePrintModule , parsePrintModuleTests , processModule , pPrintModuleAndCheck -- re-export from utils: , extractCommentConfigs , TraceFunc(TraceFunc) ) where import Control.Monad.Trans.Except import Data.CZipWith import qualified Data.Text as Text import qualified Data.Text.Lazy as TextL import qualified GHC hiding ( parseModule ) import qualified GHC.Driver.Session as GHC import GHC.Hs import qualified GHC.LanguageExtensions.Type as GHC import qualified GHC.OldList as List import Language.Haskell.Brittany.Internal.Config.Config import Language.Haskell.Brittany.Internal.Config.InlineParsing import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.S3_ToBriDocTools import Language.Haskell.Brittany.Internal.Prelude import qualified Language.Haskell.Brittany.Internal.S1_Parsing as Parsing import Language.Haskell.Brittany.Internal.StepOrchestrate ( processModule ) import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Config.Types.Instances1 () -- | Exposes the transformation in an pseudo-pure fashion. The signature -- contains `IO` due to the GHC API not exposing a pure parsing function, but -- there should be no observable effects. -- -- Note that this function ignores/resets all config values regarding -- debugging, i.e. it will never use `trace`/write to stderr. -- -- Note that the ghc parsing function used internally currently is wrapped in -- `mask_`, so cannot be killed easily. If you don't control the input, you -- may wish to put some proper upper bound on the input's size as a timeout -- won't do. parsePrintModule :: TraceFunc -> Config -> Text -> IO (Either [BrittanyError] Text) parsePrintModule traceFunc 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 (parsedSource, hasCPP) <- do let hackF s = if "#include" `isPrefixOf` s then "-- BRITANY_INCLUDE_HACK " ++ s else s let hackTransform = if hackAroundIncludes then List.intercalate "\n" . fmap hackF . lines' else id let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags then case cppMode of CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting." CPPModeWarn -> return $ Right True CPPModeNowarn -> return $ Right True else return $ Right False parseResult <- lift $ Parsing.parseModuleFromString ghcOptions "stdin" cppCheckFunc (hackTransform $ Text.unpack inputText) case parseResult of Left err -> throwE [ErrorInput err] Right x -> pure x (inlineConf, perItemConf) <- mapExceptT (fmap $ bimap (\(a, b) -> [ErrorMacroConfig a b]) id) $ extractCommentConfigs (useTraceFunc traceFunc) parsedSource 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 lift $ processModule traceFunc moduleConfig perItemConf parsedSource else lift $ pPrintModuleAndCheck traceFunc moduleConfig perItemConf parsedSource let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s pure $ if hackAroundIncludes then ( ews , TextL.intercalate (TextL.pack "\n") $ hackF <$> TextL.splitOn (TextL.pack "\n") outRaw ) else (ews, outRaw) let customErrOrder ErrorInput{} = 5 customErrOrder LayoutWarning{} = 0 :: Int customErrOrder ErrorOutputCheck{} = 1 customErrOrder ErrorUnusedComment{} = 2 customErrOrder ErrorUnusedComments{} = 3 customErrOrder ErrorUnknownNode{} = 4 customErrOrder ErrorMacroConfig{} = 6 let hasErrors = if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack then not $ null errsWarns else 0 < maximum (-1 : fmap customErrOrder errsWarns) if hasErrors then throwE $ errsWarns else pure $ TextL.toStrict outputTextL -- | Additionally checks that the output compiles again, appending an error -- if it does not. pPrintModuleAndCheck :: TraceFunc -> Config -> PerItemConfig -> GHC.ParsedSource -> IO ([BrittanyError], TextL.Text) pPrintModuleAndCheck traceFunc conf inlineConf parsedModule = do let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity (errs, output) <- processModule traceFunc conf inlineConf parsedModule parseResult <- Parsing.parseModuleFromString ghcOptions "output" (\_ -> return $ Right ()) (TextL.unpack output) let errs' = errs ++ case parseResult of Left x -> [ErrorOutputCheck x] Right{} -> [] return (errs', output) -- used for testing mostly, currently. -- TODO: use parsePrintModule instead and remove this function. parsePrintModuleTests :: Config -> String -> Text -> IO (Either String Text) parsePrintModuleTests conf filename input = do let inputStr = Text.unpack input parseResult <- Parsing.parseModuleFromString (conf & _conf_forward & _options_ghc & runIdentity) filename (const . pure $ Right ()) inputStr case parseResult of Left err -> return $ Left err Right (parsedModule, _) -> runExceptT $ do (inlineConf, perItemConf) <- mapExceptT (fmap (bimap (\(a, _) -> "when parsing inline config: " ++ a) id)) $ extractCommentConfigs (\_ -> pure ()) parsedModule let moduleConf = cZipWith fromOptionIdentity conf inlineConf let omitCheck = conf & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack (errs, ltext) <- if omitCheck then lift $ processModule (TraceFunc $ \_ -> pure ()) moduleConf perItemConf parsedModule else lift $ pPrintModuleAndCheck (TraceFunc $ \_ -> pure ()) moduleConf perItemConf parsedModule if null errs then pure $ TextL.toStrict $ ltext else throwE $ "pretty printing error(s):\n" ++ List.unlines (errorToString <$> errs) where errorToString :: BrittanyError -> String errorToString = \case ErrorInput str -> str ErrorUnusedComment _ -> "ErrorUnusedComment" ErrorUnusedComments _ _ _ -> "ErrorUnusedComments" LayoutWarning str -> str ErrorUnknownNode str _ -> str ErrorMacroConfig str _ -> "when parsing inline config: " ++ str ErrorOutputCheck str -> "Output is not syntactically valid: " ++ str -- 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. -- parsePrintModuleTests :: Text -> Either String Text -- parsePrintModuleTests input = do -- let dflags = GHC.unsafeGlobalDynFlags -- let fakeFileName = "SomeTestFakeFileName.hs" -- let pragmaInfo = GHC.getOptions -- dflags -- (GHC.stringToStringBuffer $ Text.unpack input) -- fakeFileName -- (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags pragmaInfo -- let parseResult = ExactPrint.Parsers.parseWith -- dflags1 -- fakeFileName -- GHC.parseModule -- inputStr -- case parseResult of -- Left (_, s) -> Left $ "parsing error: " ++ s -- Right (anns, parsedModule) -> do -- let (out, errs) = runIdentity -- $ runMultiRWSTNil -- $ Control.Monad.Trans.MultiRWS.Lazy.withMultiWriterAW -- $ Control.Monad.Trans.MultiRWS.Lazy.withMultiWriterW -- $ Control.Monad.Trans.MultiRWS.Lazy.withMultiReader anns -- $ ppModule parsedModule -- if (not $ null errs) -- then do -- let errStrs = errs <&> \case -- ErrorUnusedComment str -> str -- Left $ "pretty printing error(s):\n" ++ List.unlines errStrs -- else return $ TextL.toStrict $ Text.Builder.toLazyText out _sigHead :: Sig GhcPs -> String _sigHead = \case TypeSig _ names _ -> "TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names) _ -> "unknown sig" _bindHead :: HsBind GhcPs -> String _bindHead = \case FunBind _ fId _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) PatBind _ _pat _ ([], []) -> "PatBind smth" _ -> "unknown bind"