{-# LANGUAGE NoImplicitPrelude #-} module Language.Haskell.Brittany.Internal ( Parsing.parseModule , Parsing.parseModuleFromString , parsePrintModule , parsePrintModuleTests , processModule , pPrintModuleAndCheck -- re-export from utils: , extractCommentConfigs , TraceFunc(TraceFunc) , Splitting.splitModuleDecls , Splitting.extractDeclMap ) 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.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 qualified Language.Haskell.Brittany.Internal.S2_SplitModule as Splitting 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 let moduleElementList = Splitting.splitModuleDecls parsedSource (inlineConf, perItemConf) <- mapExceptT (fmap $ bimap (\(a, b) -> [ErrorMacroConfig a b]) id) $ extractCommentConfigs (useTraceFunc traceFunc) (Splitting.extractDeclMap parsedSource) moduleElementList 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 moduleElementList else lift $ pPrintModuleAndCheck traceFunc moduleConfig perItemConf moduleElementList 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 -> FinalList ModuleElement p -> IO ([BrittanyError], TextL.Text) pPrintModuleAndCheck traceFunc conf inlineConf moduleElementList = do let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity (errs, output) <- processModule traceFunc conf inlineConf moduleElementList 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 let moduleElementList = Splitting.splitModuleDecls parsedModule (inlineConf, perItemConf) <- mapExceptT (fmap (bimap (\(a, _) -> "when parsing inline config: " ++ a) id)) $ extractCommentConfigs (\_ -> pure ()) (Splitting.extractDeclMap parsedModule) moduleElementList 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 moduleElementList else lift $ pPrintModuleAndCheck (TraceFunc $ \_ -> pure ()) moduleConf perItemConf moduleElementList 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"