{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | The GHC-driven front end, part one: an in-process GHC session that
--   drives parse -> rename -> typecheck -> desugar over the whole home
--   module graph and hands back the (-O0, pre-simplifier) desugared Core,
--   one 'ModGuts' per home module in dependency order.
--
--   Wrinkles this module exists to handle:
--
--   * The desugarer runs GHC's simple optimizer unconditionally, and its
--     occurrence analysis drops top-level binds unreachable from an
--     /exported/ binder -- even at -O0. A file with no module header is
--     implicitly @module Main (main) where@, so everything but @main@
--     would vanish. 'ensureLiveExports' rewrites the parsed module before
--     typechecking: headerless modules become export-all.
--
--   * @mg_binds@ is strictly per-module: the target's guts contain no code
--     from imported modules (including all of rewire-user, compiled from
--     source via the loadpath). So every home module is desugared, not
--     just the target.
--
--   * GHC reports errors as 'SourceError' exceptions (from the per-module
--     phases) or through the log action (during 'load'); warnings only via
--     the log action. Both are re-routed through ReWire's 'AstError' /
--     'warnAt' machinery so @-w@/@-Werror@ and the usual error formatting
--     (filename included) keep working.
module ReWire.GHC.Session (loadCore, dumpCore) where

import ReWire.Annotation (Annote, noAnn, srcAnnote)
import ReWire.Config (Config, loadPath, start, verbose, pDebug)
import ReWire.Error (AstError, MonadError, failAt, warnAt)
import ReWire.GHC.PackagePath (bakedPackagePath)

import Control.Exception (try, SomeException)
import Control.Lens ((^.))
import Control.Monad (forM, unless, when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import System.Environment (lookupEnv, setEnv)
import System.Process (readCreateProcess, proc, CreateProcess (cwd))
import Data.Containers.ListUtils (nubOrdOn)
import Data.IORef (IORef, newIORef, readIORef, modifyIORef')
import Data.List (partition, isSuffixOf)
import Data.Text (Text)
import System.Directory (doesDirectoryExist)
import System.FilePath (takeDirectory, isAbsolute, splitSearchPath, (</>))

import qualified Data.Text    as T
import qualified Data.Text.IO as T

import GHC
      ( runGhc, getSessionDynFlags, setSessionDynFlags
      , guessTarget, setTargets, load, LoadHowMuch (..), SuccessFlag (..)
      , getModuleGraph
      , parseModule, typecheckModule, desugarModule, coreModule
      , ParsedModule (..), ModSummary (..)
      , DynFlags (..), GhcLink (..)
      , mgModSummaries
      , moduleName, moduleNameString
      )
import GHC.Core (CoreBind, Bind (..))
import GHC.Data.Bag (bagToList)
import GHC.Data.FastString (unpackFS)
import GHC.Driver.Backend (noBackend)
import GHC.Driver.Env (HscEnv (..))
import GHC.Driver.Monad (pushLogHookM, modifySession)
import GHC.Driver.Plugins (Plugins (..), StaticPlugin (..), PluginWithArgs (..))
import GHC.Driver.Session (updOptLevel)
import GHC.Hs (HsModule (..), GhcPs, IE (..), LIE, IEWrappedName (..), noExtField)
import GHC.Hs.ImpExp (ieNames)
import GHC.Parser.Annotation (noLocA)
import GHC.Paths (libdir)
import GHC.Types.Basic (mkIntWithInf)
import GHC.Types.Error (getMessages, errMsgSpan, Severity (..), MessageClass (..))
import GHC.Utils.Error (pprLocMsgEnvelopeDefault)
import GHC.Types.Name (nameOccName, occNameString, mkVarOcc)
import GHC.Types.Name.Reader (mkRdrUnqual, rdrNameOcc)
import GHC.Types.SourceError (SourceError, srcErrorMessages, handleSourceError)
import GHC.Types.SrcLoc (SrcSpan (..), GenLocated (..), srcSpanFile, srcSpanStartLine, srcSpanStartCol, srcSpanEndLine, srcSpanEndCol)
import GHC.Types.Var (Var, varName)
import GHC.Unit.Module.ModGuts (ModGuts (..))
import GHC.Utils.Logger (LogAction)
import GHC.Utils.Outputable (showSDocUnsafe, vcat, ppr)
import GHC.Utils.Panic (handleGhcException)

import qualified GHC.TypeLits.Extra.Solver
import qualified GHC.TypeLits.KnownNat.Solver
import qualified GHC.TypeLits.Normalise

-- | A diagnostic collected from GHC's log action: is-error, location, rendered text.
type Diag = (Bool, Annote, Text)

-- | Load Core for the whole home module graph and dump it (a per-module
--   binder summary; the full Core under -v). For debugging the session.
dumpCore :: (MonadError AstError m, MonadIO m) => Config -> FilePath -> m ()
dumpCore :: forall (m :: * -> *).
(MonadError AstError m, MonadIO m) =>
Config -> String -> m ()
dumpCore Config
conf String
fp = do
      gutss <- Config -> String -> m [ModGuts]
forall (m :: * -> *).
(MonadError AstError m, MonadIO m) =>
Config -> String -> m [ModGuts]
loadCore Config
conf String
fp
      liftIO $ mapM_ pr gutss
      where pr :: ModGuts -> IO ()
            pr :: ModGuts -> IO ()
pr ModGuts
guts = do
                  Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"-- ## GHC Core [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (ModuleName -> String
moduleNameString (ModuleName -> String) -> ModuleName -> String
forall a b. (a -> b) -> a -> b
$ GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (GenModule Unit -> ModuleName) -> GenModule Unit -> ModuleName
forall a b. (a -> b) -> a -> b
$ ModGuts -> GenModule Unit
mg_module ModGuts
guts) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]: "
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " ((CoreBndr -> Text) -> [CoreBndr] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack (String -> Text) -> (CoreBndr -> String) -> CoreBndr -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> String
occNameString (OccName -> String) -> (CoreBndr -> OccName) -> CoreBndr -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName (Name -> OccName) -> (CoreBndr -> Name) -> CoreBndr -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> Name
varName) ([CoreBndr] -> [Text]) -> [CoreBndr] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Bind CoreBndr -> [CoreBndr]) -> CoreProgram -> [CoreBndr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Bind CoreBndr -> [CoreBndr]
binders (CoreProgram -> [CoreBndr]) -> CoreProgram -> [CoreBndr]
forall a b. (a -> b) -> a -> b
$ ModGuts -> CoreProgram
mg_binds ModGuts
guts)
                  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config
confConfig -> Getting Bool Config Bool -> Bool
forall s a. s -> Getting a s a -> a
^.Getting Bool Config Bool
Lens' Config Bool
verbose) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SDoc -> String
showSDocUnsafe (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ CoreProgram -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CoreProgram -> SDoc) -> CoreProgram -> SDoc
forall a b. (a -> b) -> a -> b
$ ModGuts -> CoreProgram
mg_binds ModGuts
guts

            binders :: CoreBind -> [Var]
            binders :: Bind CoreBndr -> [CoreBndr]
binders = \ case
                  NonRec CoreBndr
b Expr CoreBndr
_ -> [CoreBndr
b]
                  Rec [(CoreBndr, Expr CoreBndr)]
bs     -> ((CoreBndr, Expr CoreBndr) -> CoreBndr)
-> [(CoreBndr, Expr CoreBndr)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, Expr CoreBndr) -> CoreBndr
forall a b. (a, b) -> a
fst [(CoreBndr, Expr CoreBndr)]
bs

-- | Load @fp@ (and, recursively, its imports from the loadpath) through GHC,
--   returning the -O0 desugared Core of every home module. GHC errors are
--   re-raised as 'AstError's; GHC warnings are re-emitted through 'warnAt'.
loadCore :: (MonadError AstError m, MonadIO m) => Config -> FilePath -> m [ModGuts]
loadCore :: forall (m :: * -> *).
(MonadError AstError m, MonadIO m) =>
Config -> String -> m [ModGuts]
loadCore Config
conf String
fp = do
      Config -> Text -> m ()
forall (m :: * -> *). MonadIO m => Config -> Text -> m ()
pDebug Config
conf (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"GHC session: libdir: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
libdir
      Config -> m ()
forall (m :: * -> *). MonadIO m => Config -> m ()
discoverPackageDBs Config
conf
      diags <- IO (IORef [Diag]) -> m (IORef [Diag])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [Diag]) -> m (IORef [Diag]))
-> IO (IORef [Diag]) -> m (IORef [Diag])
forall a b. (a -> b) -> a -> b
$ [Diag] -> IO (IORef [Diag])
forall a. a -> IO (IORef a)
newIORef ([] :: [Diag])
      -- GhcExceptions (panics, usage errors) are IO exceptions, not
      -- SourceErrors.
      r     <- liftIO $ handleGhcException (pure . Left . (noAnn,) . ("ghc-frontend: " <>) . T.pack . show)
                  $ runGhc (Just libdir) $ handleSourceError (pure . Left . renderSourceError) $ do
            df0 <- getSessionDynFlags
            setSessionDynFlags $ configure conf fp df0
            modifySession $ \ HscEnv
h -> HscEnv
h { hsc_plugins = (hsc_plugins h) { staticPlugins = typelitsPlugins } }
            pushLogHookM $ const $ logHook diags
            t   <- guessTarget fp Nothing Nothing
            setTargets [t]
            ok  <- load LoadAllTargets
            case ok of
                  SuccessFlag
Failed    -> Either (Annote, Text) [ModGuts]
-> Ghc (Either (Annote, Text) [ModGuts])
forall a. a -> Ghc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Annote, Text) [ModGuts]
 -> Ghc (Either (Annote, Text) [ModGuts]))
-> Either (Annote, Text) [ModGuts]
-> Ghc (Either (Annote, Text) [ModGuts])
forall a b. (a -> b) -> a -> b
$ (Annote, Text) -> Either (Annote, Text) [ModGuts]
forall a b. a -> Either a b
Left (Annote
noAnn, Text
"") -- Errors are in the log; see below.
                  SuccessFlag
Succeeded -> do
                        g     <- Ghc ModuleGraph
forall (m :: * -> *). GhcMonad m => m ModuleGraph
getModuleGraph
                        gutss <- forM (mgModSummaries g) $ \ ModSummary
ms -> do
                              pm  <- ModSummary -> Ghc ParsedModule
forall (m :: * -> *). GhcMonad m => ModSummary -> m ParsedModule
parseModule ModSummary
ms
                              tcm <- typecheckModule $ ensureLiveExports conf ms pm
                              dsm <- desugarModule tcm
                              pure $ coreModule dsm
                        pure $ Right gutss
      -- The graph is typechecked twice (once by load, once per-module for
      -- desugaring), so identical diagnostics arrive twice: dedupe (the
      -- rendered text embeds the location, so the key is location-aware).
      ds <- nubOrdOn (\ (Bool
e, Annote
_, Text
m) -> (Bool
e, Text
m)) . reverse <$> liftIO (readIORef diags)
      mapM_ (\ (Bool
_, Annote
an, Text
m) -> Config -> Annote -> Text -> m ()
forall (m :: * -> *) an.
(MonadError AstError m, MonadIO m, Annotation an) =>
Config -> an -> Text -> m ()
warnAt Config
conf Annote
an Text
m) $ filter (not . isError) ds
      case r of
            Right [ModGuts]
gutss -> do
                  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((ModGuts -> Bool) -> [ModGuts] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Config -> ModGuts -> Bool
definesStart Config
conf) [ModGuts]
gutss) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Annote -> Text -> m ()
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
noAnn
                        (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"ghc-frontend: no definition for the start symbol ("
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Config
confConfig -> Getting Text Config Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text Config Text
Lens' Config Text
start Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") found in the compiled modules."
                  [ModGuts] -> m [ModGuts]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ModGuts]
gutss
            Left (Annote
an, Text
msg)
                  | Bool -> Bool
not (Text -> Bool
T.null Text
msg)                -> Annote -> Text -> m [ModGuts]
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
an Text
msg
                  | (Diag
e : [Diag]
_) <- (Diag -> Bool) -> [Diag] -> [Diag]
forall a. (a -> Bool) -> [a] -> [a]
filter Diag -> Bool
isError [Diag]
ds    -> Annote -> Text -> m [ModGuts]
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt (Diag -> Annote
dAn Diag
e)
                        (Text -> m [ModGuts]) -> Text -> m [ModGuts]
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Diag -> Text) -> [Diag] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Diag -> Text
dMsg ([Diag] -> [Text]) -> [Diag] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Diag -> Bool) -> [Diag] -> [Diag]
forall a. (a -> Bool) -> [a] -> [a]
filter Diag -> Bool
isError [Diag]
ds
                  | Bool
otherwise                       -> Annote -> Text -> m [ModGuts]
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
noAnn
                        Text
"ghc-frontend: GHC failed to load the program (no diagnostics)."
      where isError :: Diag -> Bool
            isError :: Diag -> Bool
isError (Bool
e, Annote
_, Text
_) = Bool
e

            dAn :: Diag -> Annote
            dAn :: Diag -> Annote
dAn (Bool
_, Annote
an, Text
_) = Annote
an

            dMsg :: Diag -> Text
            dMsg :: Diag -> Text
dMsg (Bool
_, Annote
_, Text
m) = Text
m

-- | The GHC session needs the package databases rwc was built against —
--   not for the typechecker plugins (those are linked in; see
--   'typelitsPlugins') but for the interface files of rewire-user's
--   library dependencies (monad-resumption, vector-sized, ...), which the
--   session must resolve while compiling the loadpath sources. The chain:
--
--   1. GHC_PACKAGE_PATH already set (`stack run`/`stack exec`, the
--      documented invocation): nothing to do.
--   2. An explicit RWC_PACKAGE_PATH: honored verbatim.
--   3. The path baked in at build time ('bakedPackagePath'), if every
--      database in it still exists — the common installed-rwc case, no
--      stack needed at run time.
--   4. Ask `stack path --ghc-package-path` — run from inside the ReWire
--      checkout rwc was built from, not the caller's directory: the
--      system loadpath entry (the data directory's rewire-user/src) lives
--      in that checkout, and anchoring there keeps stack from resolving
--      the caller's enclosing (or the global) stack project, whose
--      databases lack rewire-user's dependencies.
discoverPackageDBs :: MonadIO m => Config -> m ()
discoverPackageDBs :: forall (m :: * -> *). MonadIO m => Config -> m ()
discoverPackageDBs Config
conf = IO (Maybe String) -> m (Maybe String)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO (Maybe String)
lookupEnv String
"GHC_PACKAGE_PATH") m (Maybe String) -> (Maybe String -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
      Just String
_  -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Maybe String
Nothing -> IO (Maybe String) -> m (Maybe String)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO (Maybe String)
lookupEnv String
"RWC_PACKAGE_PATH") m (Maybe String) -> (Maybe String -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
            Just String
p  -> do
                  Config -> Text -> m ()
forall (m :: * -> *). MonadIO m => Config -> Text -> m ()
pDebug Config
conf (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"GHC session: using RWC_PACKAGE_PATH: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
p
                  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
setEnv String
"GHC_PACKAGE_PATH" String
p
            Maybe String
Nothing -> IO (Maybe String) -> m (Maybe String)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Maybe String)
validBakedPath m (Maybe String) -> (Maybe String -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
                  Just String
p  -> do
                        Config -> Text -> m ()
forall (m :: * -> *). MonadIO m => Config -> Text -> m ()
pDebug Config
conf (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"GHC session: using the baked-in package path: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
p
                        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
setEnv String
"GHC_PACKAGE_PATH" String
p
                  Maybe String
Nothing -> do
                        anchor <- IO (Maybe String) -> m (Maybe String)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> m (Maybe String))
-> IO (Maybe String) -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ [String] -> IO (Maybe String)
firstExisting ([String] -> IO (Maybe String)) -> [String] -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ ([String] -> [String] -> [String])
-> ([String], [String]) -> [String]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
(<>)
                              (([String], [String]) -> [String])
-> ([String], [String]) -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((String
"rewire-user" String -> String -> String
</> String
"src") String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`)
                              ([String] -> ([String], [String]))
-> [String] -> ([String], [String])
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
isAbsolute ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Config
confConfig -> Getting [String] Config [String] -> [String]
forall s a. s -> Getting a s a -> a
^.Getting [String] Config [String]
Lens' Config [String]
loadPath
                        pDebug conf $ "GHC session: `stack path` anchor: " <> T.pack (show anchor)
                        r <- liftIO $ try $ readCreateProcess ((proc "stack" ["path", "--ghc-package-path"]) { cwd = anchor }) ""
                        case r of
                              Right (String -> String
strip -> String
p) | Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
p) -> do
                                    Config -> Text -> m ()
forall (m :: * -> *). MonadIO m => Config -> Text -> m ()
pDebug Config
conf (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"GHC session: package path from `stack path`: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
p
                                    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
setEnv String
"GHC_PACKAGE_PATH" String
p
                              Right String
_                  -> m ()
forall (m :: * -> *). MonadIO m => m ()
hint
                              Left (SomeException
_ :: SomeException) -> m ()
forall (m :: * -> *). MonadIO m => m ()
hint
      where hint :: MonadIO m => m ()
            hint :: forall (m :: * -> *). MonadIO m => m ()
hint = Config -> Text -> m ()
forall (m :: * -> *). MonadIO m => Config -> Text -> m ()
pDebug Config
conf Text
"GHC session: no package databases found (GHC_PACKAGE_PATH and RWC_PACKAGE_PATH unset, the build-time package databases are gone, and `stack path` is unavailable); module resolution will likely fail. Run rwc under `stack exec`, or set RWC_PACKAGE_PATH to the ghc package path rwc was built with."

            -- The build-time package path, provided every database in it
            -- still exists (else it is stale: the snapshot or checkout
            -- moved or was garbage-collected since the build).
            validBakedPath :: IO (Maybe FilePath)
            validBakedPath :: IO (Maybe String)
validBakedPath = case Maybe String
bakedPackagePath of
                  Maybe String
Nothing -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
                  Just String
p  -> do
                        ok <- [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> IO [Bool] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO Bool) -> [String] -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> IO Bool
doesDirectoryExist (String -> [String]
splitSearchPath String
p)
                        pure $ if ok then Just p else Nothing

            -- The first extant candidate (the loadpath's system entry may
            -- not exist for an unusual installation; fall back to the
            -- caller's directory).
            firstExisting :: [FilePath] -> IO (Maybe FilePath)
            firstExisting :: [String] -> IO (Maybe String)
firstExisting = \ case
                  []       -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
                  String
d : [String]
rest -> String -> IO Bool
doesDirectoryExist String
d IO Bool -> (Bool -> IO (Maybe String)) -> IO (Maybe String)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Bool
ok ->
                        if Bool
ok then Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe String
forall a. a -> Maybe a
Just String
d) else [String] -> IO (Maybe String)
firstExisting [String]
rest

            strip :: String -> String
            strip :: String -> String
strip = Text -> String
T.unpack (Text -> String) -> (String -> Text) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

-- | DynFlags for the ReWire session: no code generation, no optimization
--   (-O0 keeps the reactive class selectors recognizable and the extern
--   descriptor literals local), and loadpath as import paths. The target's
--   own directory heads the import paths, mirroring the HSE loader's
--   search order (Cache.hs: the importing module's directory comes before
--   the loadpath).
configure :: Config -> FilePath -> DynFlags -> DynFlags
configure :: Config -> String -> DynFlags -> DynFlags
configure Config
conf String
fp DynFlags
df = (Int -> DynFlags -> DynFlags
updOptLevel Int
0 DynFlags
df)
      { backend        = noBackend
      , ghcLink        = NoLink
      , importPaths    = takeDirectory fp : conf^.loadPath <> importPaths df
      , reductionDepth = mkIntWithInf 1000
      }

-- | The three typelits solver plugins, injected statically: they are
--   linked into rwc as ordinary library dependencies, so enabling them
--   needs no package database and no dynamic object loading at run time
--   (both of which -fplugin/pluginModNames would require, version-matched
--   to the ghc rwc links). Static plugins apply to every module the
--   session compiles, on both the load and the API typecheckModule paths.
typelitsPlugins :: [StaticPlugin]
typelitsPlugins :: [StaticPlugin]
typelitsPlugins = (Plugin -> StaticPlugin) -> [Plugin] -> [StaticPlugin]
forall a b. (a -> b) -> [a] -> [b]
map (\ Plugin
p -> PluginWithArgs -> StaticPlugin
StaticPlugin (PluginWithArgs -> StaticPlugin) -> PluginWithArgs -> StaticPlugin
forall a b. (a -> b) -> a -> b
$ Plugin -> [String] -> PluginWithArgs
PluginWithArgs Plugin
p [])
      [ Plugin
GHC.TypeLits.Normalise.plugin
      , Plugin
GHC.TypeLits.KnownNat.Solver.plugin
      , Plugin
GHC.TypeLits.Extra.Solver.plugin
      ]

-- | Rewrite the parsed module so the program survives the desugarer's
--   export-driven dead-code elimination (see the module comment):
--
--   * a headerless module (implicitly @module Main (main)@) is named from
--     its summary and made export-all -- both steps are required, because
--     GHC keys the implicit-@(main)@-export behavior on the header being
--     absent, so clearing the export list alone changes nothing;
--
--   * the start module with an explicit export list that omits the start
--     symbol gets an export for it spliced in (occurrence analysis then
--     keeps its whole reachable closure). Other explicit export lists are
--     left alone -- GHC's export diagnostics already fired during 'load',
--     which sees the original source.
ensureLiveExports :: Config -> ModSummary -> ParsedModule -> ParsedModule
ensureLiveExports :: Config -> ModSummary -> ParsedModule -> ParsedModule
ensureLiveExports Config
conf ModSummary
ms ParsedModule
pm = case (HsModule GhcPs -> Maybe (XRec GhcPs ModuleName)
forall p. HsModule p -> Maybe (XRec p ModuleName)
hsmodName HsModule GhcPs
m, HsModule GhcPs -> Maybe (XRec GhcPs [LIE GhcPs])
forall p. HsModule p -> Maybe (XRec p [LIE p])
hsmodExports HsModule GhcPs
m) of
      (Maybe (GenLocated SrcSpanAnnA ModuleName)
Nothing, Maybe (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
_)          -> ParsedModule
pm { pm_parsed_source = L l m { hsmodName    = Just $ noLocA $ moduleName $ ms_mod ms
                                                             , hsmodExports = Nothing
                                                             } }
      (Just (L SrcSpanAnnA
_ ModuleName
mn), Just (L SrcSpanAnnL
le [GenLocated SrcSpanAnnA (IE GhcPs)]
ies))
            | ModuleName -> String
moduleNameString ModuleName
mn String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
startMod, Bool -> Bool
not ((GenLocated SrcSpanAnnA (IE GhcPs) -> Bool)
-> [GenLocated SrcSpanAnnA (IE GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any LIE GhcPs -> Bool
GenLocated SrcSpanAnnA (IE GhcPs) -> Bool
exportsStart [GenLocated SrcSpanAnnA (IE GhcPs)]
ies)
                              -> ParsedModule
pm { pm_parsed_source = L l m { hsmodExports = Just $ L le $ ies <> [startIE] } }
      (Maybe (GenLocated SrcSpanAnnA ModuleName),
 Maybe (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]))
_                     -> ParsedModule
pm
      where L SrcSpan
l HsModule GhcPs
m = ParsedModule -> GenLocated SrcSpan (HsModule GhcPs)
pm_parsed_source ParsedModule
pm

            startMod, startOcc :: String
            (String
startMod, String
startOcc) = Text -> (String, String)
splitStart (Text -> (String, String)) -> Text -> (String, String)
forall a b. (a -> b) -> a -> b
$ Config
confConfig -> Getting Text Config Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text Config Text
Lens' Config Text
start

            exportsStart :: LIE GhcPs -> Bool
            exportsStart :: LIE GhcPs -> Bool
exportsStart (L SrcSpanAnnA
_ IE GhcPs
ie) = case IE GhcPs
ie of
                  IEModuleContents XIEModuleContents GhcPs
_ (L SrcSpanAnnA
_ ModuleName
mn') -> ModuleName -> String
moduleNameString ModuleName
mn' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
startMod
                  IE GhcPs
_                            -> (RdrName -> Bool) -> [RdrName] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== String -> OccName
mkVarOcc String
startOcc) (OccName -> Bool) -> (RdrName -> OccName) -> RdrName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc) ([RdrName] -> Bool) -> [RdrName] -> Bool
forall a b. (a -> b) -> a -> b
$ IE GhcPs -> [IdP GhcPs]
forall (p :: Pass). IE (GhcPass p) -> [IdP (GhcPass p)]
ieNames IE GhcPs
ie

            startIE :: LIE GhcPs
            startIE :: LIE GhcPs
startIE = IE GhcPs -> GenLocated SrcSpanAnnA (IE GhcPs)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (IE GhcPs -> GenLocated SrcSpanAnnA (IE GhcPs))
-> IE GhcPs -> GenLocated SrcSpanAnnA (IE GhcPs)
forall a b. (a -> b) -> a -> b
$ XIEVar GhcPs
-> LIEWrappedName GhcPs -> Maybe (ExportDoc GhcPs) -> IE GhcPs
forall pass.
XIEVar pass
-> LIEWrappedName pass -> Maybe (ExportDoc pass) -> IE pass
IEVar Maybe (GenLocated SrcSpanAnnP (WarningTxt GhcPs))
XIEVar GhcPs
forall a. Maybe a
Nothing (IEWrappedName GhcPs -> GenLocated SrcSpanAnnA (IEWrappedName GhcPs)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (IEWrappedName GhcPs
 -> GenLocated SrcSpanAnnA (IEWrappedName GhcPs))
-> IEWrappedName GhcPs
-> GenLocated SrcSpanAnnA (IEWrappedName GhcPs)
forall a b. (a -> b) -> a -> b
$ XIEName GhcPs -> LIdP GhcPs -> IEWrappedName GhcPs
forall p. XIEName p -> LIdP p -> IEWrappedName p
IEName XIEName GhcPs
NoExtField
noExtField (LIdP GhcPs -> IEWrappedName GhcPs)
-> LIdP GhcPs -> IEWrappedName GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName -> GenLocated SrcSpanAnnN RdrName
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (RdrName -> GenLocated SrcSpanAnnN RdrName)
-> RdrName -> GenLocated SrcSpanAnnN RdrName
forall a b. (a -> b) -> a -> b
$ OccName -> RdrName
mkRdrUnqual (OccName -> RdrName) -> OccName -> RdrName
forall a b. (a -> b) -> a -> b
$ String -> OccName
mkVarOcc String
startOcc) Maybe (ExportDoc GhcPs)
forall a. Maybe a
Nothing

-- | Does any bind in the guts define the (unqualified) start symbol in the
--   start module?
definesStart :: Config -> ModGuts -> Bool
definesStart :: Config -> ModGuts -> Bool
definesStart Config
conf ModGuts
guts = ModuleName -> String
moduleNameString (GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (ModGuts -> GenModule Unit
mg_module ModGuts
guts)) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
startMod
      Bool -> Bool -> Bool
&& (CoreBndr -> Bool) -> [CoreBndr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
startOcc) (String -> Bool) -> (CoreBndr -> String) -> CoreBndr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> String
occNameString (OccName -> String) -> (CoreBndr -> OccName) -> CoreBndr -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName (Name -> OccName) -> (CoreBndr -> Name) -> CoreBndr -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> Name
varName) ((Bind CoreBndr -> [CoreBndr]) -> CoreProgram -> [CoreBndr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Bind CoreBndr -> [CoreBndr]
binders (ModGuts -> CoreProgram
mg_binds ModGuts
guts))
      where startMod, startOcc :: String
            (String
startMod, String
startOcc) = Text -> (String, String)
splitStart (Text -> (String, String)) -> Text -> (String, String)
forall a b. (a -> b) -> a -> b
$ Config
confConfig -> Getting Text Config Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text Config Text
Lens' Config Text
start

            binders :: CoreBind -> [Var]
            binders :: Bind CoreBndr -> [CoreBndr]
binders = \ case
                  NonRec CoreBndr
b Expr CoreBndr
_ -> [CoreBndr
b]
                  Rec [(CoreBndr, Expr CoreBndr)]
bs     -> ((CoreBndr, Expr CoreBndr) -> CoreBndr)
-> [(CoreBndr, Expr CoreBndr)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, Expr CoreBndr) -> CoreBndr
forall a b. (a, b) -> a
fst [(CoreBndr, Expr CoreBndr)]
bs

-- | Split a qualified start symbol ("Main.start") into module and
--   occurrence parts.
splitStart :: Text -> (String, String)
splitStart :: Text -> (String, String)
splitStart Text
s = case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOnEnd Text
"." Text
s of
      (Text
"", Text
occ) -> (String
"Main", Text -> String
T.unpack Text
occ)
      (Text
m, Text
occ)  -> (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.dropEnd Int
1 Text
m, Text -> String
T.unpack Text
occ)

-- | Render a SourceError (thrown by the per-module parse\/typecheck\/desugar
--   phases) to an annotated message.
renderSourceError :: SourceError -> (Annote, Text)
renderSourceError :: SourceError -> (Annote, Text)
renderSourceError SourceError
e = (Annote
an, String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SDoc -> String
showSDocUnsafe (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (MsgEnvelope GhcMessage -> SDoc)
-> [MsgEnvelope GhcMessage] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map MsgEnvelope GhcMessage -> SDoc
forall e. Diagnostic e => MsgEnvelope e -> SDoc
pprLocMsgEnvelopeDefault [MsgEnvelope GhcMessage]
envs)
      where envs :: [MsgEnvelope GhcMessage]
envs = Bag (MsgEnvelope GhcMessage) -> [MsgEnvelope GhcMessage]
forall a. Bag a -> [a]
bagToList (Bag (MsgEnvelope GhcMessage) -> [MsgEnvelope GhcMessage])
-> Bag (MsgEnvelope GhcMessage) -> [MsgEnvelope GhcMessage]
forall a b. (a -> b) -> a -> b
$ Messages GhcMessage -> Bag (MsgEnvelope GhcMessage)
forall e. Messages e -> Bag (MsgEnvelope e)
getMessages (Messages GhcMessage -> Bag (MsgEnvelope GhcMessage))
-> Messages GhcMessage -> Bag (MsgEnvelope GhcMessage)
forall a b. (a -> b) -> a -> b
$ SourceError -> Messages GhcMessage
srcErrorMessages SourceError
e
            an :: Annote
an   = case [MsgEnvelope GhcMessage]
envs of
                  (MsgEnvelope GhcMessage
env : [MsgEnvelope GhcMessage]
_) -> SrcSpan -> Annote
spanAnnote (SrcSpan -> Annote) -> SrcSpan -> Annote
forall a b. (a -> b) -> a -> b
$ MsgEnvelope GhcMessage -> SrcSpan
forall e. MsgEnvelope e -> SrcSpan
errMsgSpan MsgEnvelope GhcMessage
env
                  [MsgEnvelope GhcMessage]
_         -> Annote
noAnn

-- | The log hook: collect warnings and errors (errors reach the log action
--   during 'load'; they do not raise SourceError there).
logHook :: IORef [Diag] -> LogAction
logHook :: IORef [Diag] -> LogAction
logHook IORef [Diag]
diags LogFlags
_lf MessageClass
mc SrcSpan
loc SDoc
doc = case MessageClass
mc of
      MCDiagnostic Severity
SevError ResolvedDiagnosticReason
_ Maybe DiagnosticCode
_   -> IORef [Diag] -> ([Diag] -> [Diag]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [Diag]
diags ((Bool
True, SrcSpan -> Annote
spanAnnote SrcSpan
loc, Text
msg) Diag -> [Diag] -> [Diag]
forall a. a -> [a] -> [a]
:)
      MCDiagnostic Severity
SevWarning ResolvedDiagnosticReason
_ Maybe DiagnosticCode
_ -> IORef [Diag] -> ([Diag] -> [Diag]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [Diag]
diags ((Bool
False, SrcSpan -> Annote
spanAnnote SrcSpan
loc, Text
msg) Diag -> [Diag] -> [Diag]
forall a. a -> [a] -> [a]
:)
      MessageClass
_                           -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      where msg :: Text
            msg :: Text
msg = String -> Text
T.pack (SDoc -> String
showSDocUnsafe (SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
loc)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (SDoc -> String
showSDocUnsafe SDoc
doc)

spanAnnote :: SrcSpan -> Annote
spanAnnote :: SrcSpan -> Annote
spanAnnote = \ case
      RealSrcSpan RealSrcSpan
rs Maybe BufSpan
_ -> String -> (Int, Int) -> (Int, Int) -> Annote
srcAnnote (FastString -> String
unpackFS (FastString -> String) -> FastString -> String
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
rs)
                                    (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
rs, RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
rs)
                                    (RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
rs, RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
rs)
      UnhelpfulSpan UnhelpfulSpanReason
_  -> Annote
noAnn