{-# LANGUAGE BangPatterns, CPP, MagicHash, NondecreasingIndentation #-}
{-# OPTIONS_GHC -fprof-auto-top #-}

-------------------------------------------------------------------------------
--
-- | Main API for compiling plain Haskell source code.
--
-- This module implements compilation of a Haskell source. It is
-- /not/ concerned with preprocessing of source files; this is handled
-- in "DriverPipeline".
--
-- There are various entry points depending on what mode we're in:
-- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and
-- "interactive" mode (GHCi). There are also entry points for
-- individual passes: parsing, typechecking/renaming, desugaring, and
-- simplification.
--
-- All the functions here take an 'HscEnv' as a parameter, but none of
-- them return a new one: 'HscEnv' is treated as an immutable value
-- from here on in (although it has mutable components, for the
-- caches).
--
-- We use the Hsc monad to deal with warning messages consistently:
-- specifically, while executing within an Hsc monad, warnings are
-- collected. When a Hsc monad returns to an IO monad, the
-- warnings are printed, or compilation aborts if the @-Werror@
-- flag is enabled.
--
-- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
--
-------------------------------------------------------------------------------

module HscMain
    (
    -- * Making an HscEnv
      newHscEnv

    -- * Compiling complete source files
    , Messager, batchMsg
    , HscStatus (..)
    , hscIncrementalCompile
    , hscCompileCmmFile

    , hscGenHardCode
    , hscInteractive

    -- * Running passes separately
    , hscParse
    , hscTypecheckRename
    , hscDesugar
    , makeSimpleDetails
    , hscSimplify -- ToDo, shouldn't really export this

    -- * Safe Haskell
    , hscCheckSafe
    , hscGetSafe

    -- * Support for interactive evaluation
    , hscParseIdentifier
    , hscTcRcLookupName
    , hscTcRnGetInfo
    , hscIsGHCiMonad
    , hscGetModuleInterface
    , hscRnImportDecls
    , hscTcRnLookupRdrName
    , hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt
    , hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls
    , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType
    , hscParseExpr
    , hscCompileCoreExpr
    -- * Low-level exports for hooks
    , hscCompileCoreExpr'
      -- We want to make sure that we export enough to be able to redefine
      -- hscFileFrontEnd in client code
    , hscParse', hscSimplify', hscDesugar', tcRnModule'
    , getHscEnv
    , hscSimpleIface', hscNormalIface'
    , oneShotMsg
    , hscFileFrontEnd, genericHscFrontend, dumpIfaceStats
    , ioMsgMaybe
    , showModuleIndex
    , hscAddSptEntries
    ) where

import GhcPrelude

import Data.Data hiding (Fixity, TyCon)
import Data.Maybe       ( fromJust )
import Id
import GHCi             ( addSptEntry )
import GHCi.RemoteTypes ( ForeignHValue )
import ByteCodeGen      ( byteCodeGen, coreExprToBCOs )
import Linker
import CoreTidy         ( tidyExpr )
import Type             ( Type )
import {- Kind parts of -} Type         ( Kind )
import CoreLint         ( lintInteractiveExpr )
import VarEnv           ( emptyTidyEnv )
import Panic
import ConLike
import Control.Concurrent

import Module
import Packages
import RdrName
import HsSyn
import HsDumpAst
import CoreSyn
import StringBuffer
import Parser
import Lexer
import SrcLoc
import TcRnDriver
import TcIface          ( typecheckIface )
import TcRnMonad
import NameCache        ( initNameCache )
import LoadIface        ( ifaceStats, initExternalPackageState )
import PrelInfo
import MkIface
import Desugar
import SimplCore
import TidyPgm
import CorePrep
import CoreToStg        ( coreToStg )
import qualified StgCmm ( codeGen )
import StgSyn
import StgFVs           ( annTopBindingsFreeVars )
import CostCentre
import ProfInit
import TyCon
import Name
import SimplStg         ( stg2stg )
import Cmm
import CmmParse         ( parseCmmFile )
import CmmBuildInfoTables
import CmmPipeline
import CmmInfo
import CodeOutput
import InstEnv
import FamInstEnv
import Fingerprint      ( Fingerprint )
import Hooks
import TcEnv
import PrelNames
import Plugins
import DynamicLoading   ( initializePlugins )

import DynFlags
import ErrUtils
import Platform ( platformOS, osSubsectionsViaSymbols )

import Outputable
import NameEnv
import HscStats         ( ppSourceStats )
import HscTypes
import FastString
import UniqSupply
import Bag
import Exception
import qualified Stream
import Stream (Stream)

import Util

import Data.List
import Control.Monad
import Data.IORef
import System.FilePath as FilePath
import System.Directory
import System.IO (fixIO)
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Set (Set)

import HieAst           ( mkHieFile )
import HieTypes         ( getAsts, hie_asts )
import HieBin           ( readHieFile, writeHieFile , hie_file_result)
import HieDebug         ( diffFile, validateScopes )

#include "HsVersions.h"


{- **********************************************************************
%*                                                                      *
                Initialisation
%*                                                                      *
%********************************************************************* -}

newHscEnv :: DynFlags -> IO HscEnv
newHscEnv :: DynFlags -> IO HscEnv
newHscEnv dflags :: DynFlags
dflags = do
    IORef ExternalPackageState
eps_var <- ExternalPackageState -> IO (IORef ExternalPackageState)
forall a. a -> IO (IORef a)
newIORef ExternalPackageState
initExternalPackageState
    UniqSupply
us      <- Char -> IO UniqSupply
mkSplitUniqSupply 'r'
    IORef NameCache
nc_var  <- NameCache -> IO (IORef NameCache)
forall a. a -> IO (IORef a)
newIORef (UniqSupply -> [Name] -> NameCache
initNameCache UniqSupply
us [Name]
knownKeyNames)
    IORef (InstalledModuleEnv InstalledFindResult)
fc_var  <- InstalledModuleEnv InstalledFindResult
-> IO (IORef (InstalledModuleEnv InstalledFindResult))
forall a. a -> IO (IORef a)
newIORef InstalledModuleEnv InstalledFindResult
forall a. InstalledModuleEnv a
emptyInstalledModuleEnv
    MVar (Maybe IServ)
iserv_mvar <- Maybe IServ -> IO (MVar (Maybe IServ))
forall a. a -> IO (MVar a)
newMVar Maybe IServ
forall a. Maybe a
Nothing
    HscEnv -> IO HscEnv
forall (m :: * -> *) a. Monad m => a -> m a
return $WHscEnv :: DynFlags
-> [Target]
-> ModuleGraph
-> InteractiveContext
-> HomePackageTable
-> IORef ExternalPackageState
-> IORef NameCache
-> IORef (InstalledModuleEnv InstalledFindResult)
-> Maybe (Module, IORef TypeEnv)
-> MVar (Maybe IServ)
-> HscEnv
HscEnv {  hsc_dflags :: DynFlags
hsc_dflags       = DynFlags
dflags
                  ,  hsc_targets :: [Target]
hsc_targets      = []
                  ,  hsc_mod_graph :: ModuleGraph
hsc_mod_graph    = ModuleGraph
emptyMG
                  ,  hsc_IC :: InteractiveContext
hsc_IC           = DynFlags -> InteractiveContext
emptyInteractiveContext DynFlags
dflags
                  ,  hsc_HPT :: HomePackageTable
hsc_HPT          = HomePackageTable
emptyHomePackageTable
                  ,  hsc_EPS :: IORef ExternalPackageState
hsc_EPS          = IORef ExternalPackageState
eps_var
                  ,  hsc_NC :: IORef NameCache
hsc_NC           = IORef NameCache
nc_var
                  ,  hsc_FC :: IORef (InstalledModuleEnv InstalledFindResult)
hsc_FC           = IORef (InstalledModuleEnv InstalledFindResult)
fc_var
                  ,  hsc_type_env_var :: Maybe (Module, IORef TypeEnv)
hsc_type_env_var = Maybe (Module, IORef TypeEnv)
forall a. Maybe a
Nothing
                  , hsc_iserv :: MVar (Maybe IServ)
hsc_iserv        = MVar (Maybe IServ)
iserv_mvar
                  }

-- -----------------------------------------------------------------------------

getWarnings :: Hsc WarningMessages
getWarnings :: Hsc WarningMessages
getWarnings = (HscEnv
 -> WarningMessages -> IO (WarningMessages, WarningMessages))
-> Hsc WarningMessages
forall a.
(HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a
Hsc ((HscEnv
  -> WarningMessages -> IO (WarningMessages, WarningMessages))
 -> Hsc WarningMessages)
-> (HscEnv
    -> WarningMessages -> IO (WarningMessages, WarningMessages))
-> Hsc WarningMessages
forall a b. (a -> b) -> a -> b
$ \_ w :: WarningMessages
w -> (WarningMessages, WarningMessages)
-> IO (WarningMessages, WarningMessages)
forall (m :: * -> *) a. Monad m => a -> m a
return (WarningMessages
w, WarningMessages
w)

clearWarnings :: Hsc ()
clearWarnings :: Hsc ()
clearWarnings = (HscEnv -> WarningMessages -> IO ((), WarningMessages)) -> Hsc ()
forall a.
(HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a
Hsc ((HscEnv -> WarningMessages -> IO ((), WarningMessages)) -> Hsc ())
-> (HscEnv -> WarningMessages -> IO ((), WarningMessages))
-> Hsc ()
forall a b. (a -> b) -> a -> b
$ \_ _ -> ((), WarningMessages) -> IO ((), WarningMessages)
forall (m :: * -> *) a. Monad m => a -> m a
return ((), WarningMessages
forall a. Bag a
emptyBag)

logWarnings :: WarningMessages -> Hsc ()
logWarnings :: WarningMessages -> Hsc ()
logWarnings w :: WarningMessages
w = (HscEnv -> WarningMessages -> IO ((), WarningMessages)) -> Hsc ()
forall a.
(HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a
Hsc ((HscEnv -> WarningMessages -> IO ((), WarningMessages)) -> Hsc ())
-> (HscEnv -> WarningMessages -> IO ((), WarningMessages))
-> Hsc ()
forall a b. (a -> b) -> a -> b
$ \_ w0 :: WarningMessages
w0 -> ((), WarningMessages) -> IO ((), WarningMessages)
forall (m :: * -> *) a. Monad m => a -> m a
return ((), WarningMessages
w0 WarningMessages -> WarningMessages -> WarningMessages
forall a. Bag a -> Bag a -> Bag a
`unionBags` WarningMessages
w)

getHscEnv :: Hsc HscEnv
getHscEnv :: Hsc HscEnv
getHscEnv = (HscEnv -> WarningMessages -> IO (HscEnv, WarningMessages))
-> Hsc HscEnv
forall a.
(HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a
Hsc ((HscEnv -> WarningMessages -> IO (HscEnv, WarningMessages))
 -> Hsc HscEnv)
-> (HscEnv -> WarningMessages -> IO (HscEnv, WarningMessages))
-> Hsc HscEnv
forall a b. (a -> b) -> a -> b
$ \e :: HscEnv
e w :: WarningMessages
w -> (HscEnv, WarningMessages) -> IO (HscEnv, WarningMessages)
forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv
e, WarningMessages
w)

handleWarnings :: Hsc ()
handleWarnings :: Hsc ()
handleWarnings = do
    DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    WarningMessages
w <- Hsc WarningMessages
getWarnings
    IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> WarningMessages -> IO ()
printOrThrowWarnings DynFlags
dflags WarningMessages
w
    Hsc ()
clearWarnings

-- | log warning in the monad, and if there are errors then
-- throw a SourceError exception.
logWarningsReportErrors :: Messages -> Hsc ()
logWarningsReportErrors :: (WarningMessages, WarningMessages) -> Hsc ()
logWarningsReportErrors (warns :: WarningMessages
warns,errs :: WarningMessages
errs) = do
    WarningMessages -> Hsc ()
logWarnings WarningMessages
warns
    Bool -> Hsc () -> Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ WarningMessages -> Bool
forall a. Bag a -> Bool
isEmptyBag WarningMessages
errs) (Hsc () -> Hsc ()) -> Hsc () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ WarningMessages -> Hsc ()
forall (io :: * -> *) a. MonadIO io => WarningMessages -> io a
throwErrors WarningMessages
errs

-- | Deal with errors and warnings returned by a compilation step
--
-- In order to reduce dependencies to other parts of the compiler, functions
-- outside the "main" parts of GHC return warnings and errors as a parameter
-- and signal success via by wrapping the result in a 'Maybe' type. This
-- function logs the returned warnings and propagates errors as exceptions
-- (of type 'SourceError').
--
-- This function assumes the following invariants:
--
--  1. If the second result indicates success (is of the form 'Just x'),
--     there must be no error messages in the first result.
--
--  2. If there are no error messages, but the second result indicates failure
--     there should be warnings in the first result. That is, if the action
--     failed, it must have been due to the warnings (i.e., @-Werror@).
ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a
ioMsgMaybe :: IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe ioA :: IO ((WarningMessages, WarningMessages), Maybe a)
ioA = do
    ((warns :: WarningMessages
warns,errs :: WarningMessages
errs), mb_r :: Maybe a
mb_r) <- IO ((WarningMessages, WarningMessages), Maybe a)
-> Hsc ((WarningMessages, WarningMessages), Maybe a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ((WarningMessages, WarningMessages), Maybe a)
ioA
    WarningMessages -> Hsc ()
logWarnings WarningMessages
warns
    case Maybe a
mb_r of
        Nothing -> WarningMessages -> Hsc a
forall (io :: * -> *) a. MonadIO io => WarningMessages -> io a
throwErrors WarningMessages
errs
        Just r :: a
r  -> ASSERT( isEmptyBag errs ) return r

-- | like ioMsgMaybe, except that we ignore error messages and return
-- 'Nothing' instead.
ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' :: IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' ioA :: IO ((WarningMessages, WarningMessages), Maybe a)
ioA = do
    ((warns :: WarningMessages
warns,_errs :: WarningMessages
_errs), mb_r :: Maybe a
mb_r) <- IO ((WarningMessages, WarningMessages), Maybe a)
-> Hsc ((WarningMessages, WarningMessages), Maybe a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ((WarningMessages, WarningMessages), Maybe a)
 -> Hsc ((WarningMessages, WarningMessages), Maybe a))
-> IO ((WarningMessages, WarningMessages), Maybe a)
-> Hsc ((WarningMessages, WarningMessages), Maybe a)
forall a b. (a -> b) -> a -> b
$ IO ((WarningMessages, WarningMessages), Maybe a)
ioA
    WarningMessages -> Hsc ()
logWarnings WarningMessages
warns
    Maybe a -> Hsc (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
mb_r

-- -----------------------------------------------------------------------------
-- | Lookup things in the compiler's environment

hscTcRnLookupRdrName :: HscEnv -> Located RdrName -> IO [Name]
hscTcRnLookupRdrName :: HscEnv -> Located RdrName -> IO [Name]
hscTcRnLookupRdrName hsc_env0 :: HscEnv
hsc_env0 rdr_name :: Located RdrName
rdr_name
  = HscEnv -> Hsc [Name] -> IO [Name]
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc [Name] -> IO [Name]) -> Hsc [Name] -> IO [Name]
forall a b. (a -> b) -> a -> b
$
    do { HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
       ; IO ((WarningMessages, WarningMessages), Maybe [Name]) -> Hsc [Name]
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO ((WarningMessages, WarningMessages), Maybe [Name])
 -> Hsc [Name])
-> IO ((WarningMessages, WarningMessages), Maybe [Name])
-> Hsc [Name]
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Located RdrName
-> IO ((WarningMessages, WarningMessages), Maybe [Name])
tcRnLookupRdrName HscEnv
hsc_env Located RdrName
rdr_name }

hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
hscTcRcLookupName hsc_env0 :: HscEnv
hsc_env0 name :: Name
name = HscEnv -> Hsc (Maybe TyThing) -> IO (Maybe TyThing)
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc (Maybe TyThing) -> IO (Maybe TyThing))
-> Hsc (Maybe TyThing) -> IO (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$ do
  HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
  IO ((WarningMessages, WarningMessages), Maybe TyThing)
-> Hsc (Maybe TyThing)
forall a.
IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' (IO ((WarningMessages, WarningMessages), Maybe TyThing)
 -> Hsc (Maybe TyThing))
-> IO ((WarningMessages, WarningMessages), Maybe TyThing)
-> Hsc (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Name -> IO ((WarningMessages, WarningMessages), Maybe TyThing)
tcRnLookupName HscEnv
hsc_env Name
name
      -- ignore errors: the only error we're likely to get is
      -- "name not found", and the Maybe in the return type
      -- is used to indicate that.

hscTcRnGetInfo :: HscEnv -> Name
               -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
hscTcRnGetInfo :: HscEnv
-> Name -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
hscTcRnGetInfo hsc_env0 :: HscEnv
hsc_env0 name :: Name
name
  = HscEnv
-> Hsc (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
 -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)))
-> Hsc (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall a b. (a -> b) -> a -> b
$
    do { HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
       ; IO
  ((WarningMessages, WarningMessages),
   Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-> Hsc (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall a.
IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' (IO
   ((WarningMessages, WarningMessages),
    Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
 -> Hsc (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)))
-> IO
     ((WarningMessages, WarningMessages),
      Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-> Hsc (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Name
-> IO
     ((WarningMessages, WarningMessages),
      Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
tcRnGetInfo HscEnv
hsc_env Name
name }

hscIsGHCiMonad :: HscEnv -> String -> IO Name
hscIsGHCiMonad :: HscEnv -> String -> IO Name
hscIsGHCiMonad hsc_env :: HscEnv
hsc_env name :: String
name
  = HscEnv -> Hsc Name -> IO Name
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc Name -> IO Name) -> Hsc Name -> IO Name
forall a b. (a -> b) -> a -> b
$ IO ((WarningMessages, WarningMessages), Maybe Name) -> Hsc Name
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO ((WarningMessages, WarningMessages), Maybe Name) -> Hsc Name)
-> IO ((WarningMessages, WarningMessages), Maybe Name) -> Hsc Name
forall a b. (a -> b) -> a -> b
$ HscEnv
-> String -> IO ((WarningMessages, WarningMessages), Maybe Name)
isGHCiMonad HscEnv
hsc_env String
name

hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
hscGetModuleInterface hsc_env0 :: HscEnv
hsc_env0 mod :: Module
mod = HscEnv -> Hsc ModIface -> IO ModIface
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc ModIface -> IO ModIface) -> Hsc ModIface -> IO ModIface
forall a b. (a -> b) -> a -> b
$ do
  HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
  IO ((WarningMessages, WarningMessages), Maybe ModIface)
-> Hsc ModIface
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO ((WarningMessages, WarningMessages), Maybe ModIface)
 -> Hsc ModIface)
-> IO ((WarningMessages, WarningMessages), Maybe ModIface)
-> Hsc ModIface
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Module
-> IO ((WarningMessages, WarningMessages), Maybe ModIface)
getModuleInterface HscEnv
hsc_env Module
mod

-- -----------------------------------------------------------------------------
-- | Rename some import declarations
hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv
hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv
hscRnImportDecls hsc_env0 :: HscEnv
hsc_env0 import_decls :: [LImportDecl GhcPs]
import_decls = HscEnv -> Hsc GlobalRdrEnv -> IO GlobalRdrEnv
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc GlobalRdrEnv -> IO GlobalRdrEnv)
-> Hsc GlobalRdrEnv -> IO GlobalRdrEnv
forall a b. (a -> b) -> a -> b
$ do
  HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
  IO ((WarningMessages, WarningMessages), Maybe GlobalRdrEnv)
-> Hsc GlobalRdrEnv
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO ((WarningMessages, WarningMessages), Maybe GlobalRdrEnv)
 -> Hsc GlobalRdrEnv)
-> IO ((WarningMessages, WarningMessages), Maybe GlobalRdrEnv)
-> Hsc GlobalRdrEnv
forall a b. (a -> b) -> a -> b
$ HscEnv
-> [LImportDecl GhcPs]
-> IO ((WarningMessages, WarningMessages), Maybe GlobalRdrEnv)
tcRnImportDecls HscEnv
hsc_env [LImportDecl GhcPs]
import_decls

-- -----------------------------------------------------------------------------
-- | parse a file, returning the abstract syntax

hscParse :: HscEnv -> ModSummary -> IO HsParsedModule
hscParse :: HscEnv -> ModSummary -> IO HsParsedModule
hscParse hsc_env :: HscEnv
hsc_env mod_summary :: ModSummary
mod_summary = HscEnv -> Hsc HsParsedModule -> IO HsParsedModule
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc HsParsedModule -> IO HsParsedModule)
-> Hsc HsParsedModule -> IO HsParsedModule
forall a b. (a -> b) -> a -> b
$ ModSummary -> Hsc HsParsedModule
hscParse' ModSummary
mod_summary

-- internal version, that doesn't fail due to -Werror
hscParse' :: ModSummary -> Hsc HsParsedModule
hscParse' :: ModSummary -> Hsc HsParsedModule
hscParse' mod_summary :: ModSummary
mod_summary
 | Just r :: HsParsedModule
r <- ModSummary -> Maybe HsParsedModule
ms_parsed_mod ModSummary
mod_summary = HsParsedModule -> Hsc HsParsedModule
forall (m :: * -> *) a. Monad m => a -> m a
return HsParsedModule
r
 | Bool
otherwise = {-# SCC "Parser" #-}
    Hsc DynFlags
-> SDoc
-> (HsParsedModule -> ())
-> Hsc HsParsedModule
-> Hsc HsParsedModule
forall (m :: * -> *) a.
MonadIO m =>
m DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
               (String -> SDoc
text "Parser"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> SDoc) -> Module -> SDoc
forall a b. (a -> b) -> a -> b
$ ModSummary -> Module
ms_mod ModSummary
mod_summary))
               (() -> HsParsedModule -> ()
forall a b. a -> b -> a
const ()) (Hsc HsParsedModule -> Hsc HsParsedModule)
-> Hsc HsParsedModule -> Hsc HsParsedModule
forall a b. (a -> b) -> a -> b
$ do
    DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let src_filename :: String
src_filename  = ModSummary -> String
ms_hspp_file ModSummary
mod_summary
        maybe_src_buf :: Maybe StringBuffer
maybe_src_buf = ModSummary -> Maybe StringBuffer
ms_hspp_buf  ModSummary
mod_summary

    --------------------------  Parser  ----------------
    -- sometimes we already have the buffer in memory, perhaps
    -- because we needed to parse the imports out of it, or get the
    -- module name.
    StringBuffer
buf <- case Maybe StringBuffer
maybe_src_buf of
               Just b :: StringBuffer
b  -> StringBuffer -> Hsc StringBuffer
forall (m :: * -> *) a. Monad m => a -> m a
return StringBuffer
b
               Nothing -> IO StringBuffer -> Hsc StringBuffer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO StringBuffer -> Hsc StringBuffer)
-> IO StringBuffer -> Hsc StringBuffer
forall a b. (a -> b) -> a -> b
$ String -> IO StringBuffer
hGetStringBuffer String
src_filename

    let loc :: RealSrcLoc
loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
mkFastString String
src_filename) 1 1
    let parseMod :: P (Located (HsModule GhcPs))
parseMod | HscSource
HsigFile HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== ModSummary -> HscSource
ms_hsc_src ModSummary
mod_summary
                 = P (Located (HsModule GhcPs))
parseSignature
                 | Bool
otherwise = P (Located (HsModule GhcPs))
parseModule

    case P (Located (HsModule GhcPs))
-> PState -> ParseResult (Located (HsModule GhcPs))
forall a. P a -> PState -> ParseResult a
unP P (Located (HsModule GhcPs))
parseMod (DynFlags -> StringBuffer -> RealSrcLoc -> PState
mkPState DynFlags
dflags StringBuffer
buf RealSrcLoc
loc) of
        PFailed warnFn :: DynFlags -> (WarningMessages, WarningMessages)
warnFn span :: SrcSpan
span err :: SDoc
err -> do
            (WarningMessages, WarningMessages) -> Hsc ()
logWarningsReportErrors (DynFlags -> (WarningMessages, WarningMessages)
warnFn DynFlags
dflags)
            Hsc ()
handleWarnings
            IO HsParsedModule -> Hsc HsParsedModule
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HsParsedModule -> Hsc HsParsedModule)
-> IO HsParsedModule -> Hsc HsParsedModule
forall a b. (a -> b) -> a -> b
$ ErrMsg -> IO HsParsedModule
forall (m :: * -> *) ab. MonadIO m => ErrMsg -> m ab
throwOneError (DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg DynFlags
dflags SrcSpan
span SDoc
err)

        POk pst :: PState
pst rdr_module :: Located (HsModule GhcPs)
rdr_module -> do
            (WarningMessages, WarningMessages) -> Hsc ()
logWarningsReportErrors (PState -> DynFlags -> (WarningMessages, WarningMessages)
getMessages PState
pst DynFlags
dflags)
            IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_parsed "Parser" (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
                                   Located (HsModule GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located (HsModule GhcPs)
rdr_module
            IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_parsed_ast "Parser AST" (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
                                   BlankSrcSpan -> Located (HsModule GhcPs) -> SDoc
forall a. Data a => BlankSrcSpan -> a -> SDoc
showAstData BlankSrcSpan
NoBlankSrcSpan Located (HsModule GhcPs)
rdr_module
            IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_source_stats "Source Statistics" (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
                                   Bool -> Located (HsModule GhcPs) -> SDoc
ppSourceStats Bool
False Located (HsModule GhcPs)
rdr_module

            -- To get the list of extra source files, we take the list
            -- that the parser gave us,
            --   - eliminate files beginning with '<'.  gcc likes to use
            --     pseudo-filenames like "<built-in>" and "<command-line>"
            --   - normalise them (eliminate differences between ./f and f)
            --   - filter out the preprocessed source file
            --   - filter out anything beginning with tmpdir
            --   - remove duplicates
            --   - filter out the .hs/.lhs source filename if we have one
            --
            let n_hspp :: String
n_hspp  = String -> String
FilePath.normalise String
src_filename
                srcs0 :: [String]
srcs0 = [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DynFlags -> String
tmpDir DynFlags
dflags String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`))
                            ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
n_hspp))
                            ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
FilePath.normalise
                            ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf "<")
                            ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (FastString -> String) -> [FastString] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map FastString -> String
unpackFS
                            ([FastString] -> [String]) -> [FastString] -> [String]
forall a b. (a -> b) -> a -> b
$ PState -> [FastString]
srcfiles PState
pst
                srcs1 :: [String]
srcs1 = case ModLocation -> Maybe String
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
mod_summary) of
                          Just f :: String
f  -> (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> String
FilePath.normalise String
f) [String]
srcs0
                          Nothing -> [String]
srcs0

            -- sometimes we see source files from earlier
            -- preprocessing stages that cannot be found, so just
            -- filter them out:
            [String]
srcs2 <- IO [String] -> Hsc [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> Hsc [String]) -> IO [String] -> Hsc [String]
forall a b. (a -> b) -> a -> b
$ (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist [String]
srcs1

            let res :: HsParsedModule
res = HsParsedModule :: Located (HsModule GhcPs) -> [String] -> ApiAnns -> HsParsedModule
HsParsedModule {
                      hpm_module :: Located (HsModule GhcPs)
hpm_module    = Located (HsModule GhcPs)
rdr_module,
                      hpm_src_files :: [String]
hpm_src_files = [String]
srcs2,
                      hpm_annotations :: ApiAnns
hpm_annotations
                              = (([SrcSpan] -> [SrcSpan] -> [SrcSpan])
-> [(ApiAnnKey, [SrcSpan])] -> Map ApiAnnKey [SrcSpan]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
(++) ([(ApiAnnKey, [SrcSpan])] -> Map ApiAnnKey [SrcSpan])
-> [(ApiAnnKey, [SrcSpan])] -> Map ApiAnnKey [SrcSpan]
forall a b. (a -> b) -> a -> b
$ PState -> [(ApiAnnKey, [SrcSpan])]
annotations PState
pst,
                                 [(SrcSpan, [Located AnnotationComment])]
-> Map SrcSpan [Located AnnotationComment]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(SrcSpan, [Located AnnotationComment])]
 -> Map SrcSpan [Located AnnotationComment])
-> [(SrcSpan, [Located AnnotationComment])]
-> Map SrcSpan [Located AnnotationComment]
forall a b. (a -> b) -> a -> b
$ ((SrcSpan
noSrcSpan,PState -> [Located AnnotationComment]
comment_q PState
pst)
                                                 (SrcSpan, [Located AnnotationComment])
-> [(SrcSpan, [Located AnnotationComment])]
-> [(SrcSpan, [Located AnnotationComment])]
forall a. a -> [a] -> [a]
:(PState -> [(SrcSpan, [Located AnnotationComment])]
annotations_comments PState
pst)))
                   }

            -- apply parse transformation of plugins
            let applyPluginAction :: Plugin -> [String] -> HsParsedModule -> Hsc HsParsedModule
applyPluginAction p :: Plugin
p opts :: [String]
opts
                  = Plugin
-> [String] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsedResultAction Plugin
p [String]
opts ModSummary
mod_summary
            DynFlags
-> (Plugin -> [String] -> HsParsedModule -> Hsc HsParsedModule)
-> HsParsedModule
-> Hsc HsParsedModule
forall (m :: * -> *) a.
Monad m =>
DynFlags -> PluginOperation m a -> a -> m a
withPlugins DynFlags
dflags Plugin -> [String] -> HsParsedModule -> Hsc HsParsedModule
applyPluginAction HsParsedModule
res


-- -----------------------------------------------------------------------------
-- | If the renamed source has been kept, extract it. Dump it if requested.
extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff
extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff
extract_renamed_stuff mod_summary :: ModSummary
mod_summary tc_result :: TcGblEnv
tc_result = do
    let rn_info :: RenamedStuff
rn_info = TcGblEnv -> RenamedStuff
getRenamedStuff TcGblEnv
tc_result

    DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_rn_ast "Renamer" (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
                           BlankSrcSpan -> RenamedStuff -> SDoc
forall a. Data a => BlankSrcSpan -> a -> SDoc
showAstData BlankSrcSpan
NoBlankSrcSpan RenamedStuff
rn_info

    -- Create HIE files
    Bool -> Hsc () -> Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteHie DynFlags
dflags) (Hsc () -> Hsc ()) -> Hsc () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ do
        -- I assume this fromJust is safe because `-fwrite-hie-file`
        -- enables the option which keeps the renamed source.
        HieFile
hieFile <- ModSummary -> TcGblEnv -> RenamedSource -> Hsc HieFile
mkHieFile ModSummary
mod_summary TcGblEnv
tc_result (RenamedStuff -> RenamedSource
forall a. HasCallStack => Maybe a -> a
fromJust RenamedStuff
rn_info)
        let out_file :: String
out_file = ModLocation -> String
ml_hie_file (ModLocation -> String) -> ModLocation -> String
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location ModSummary
mod_summary
        IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ String -> HieFile -> IO ()
writeHieFile String
out_file HieFile
hieFile

        -- Validate HIE files
        Bool -> Hsc () -> Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ValidateHie DynFlags
dflags) (Hsc () -> Hsc ()) -> Hsc () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ do
            HscEnv
hs_env <- (HscEnv -> WarningMessages -> IO (HscEnv, WarningMessages))
-> Hsc HscEnv
forall a.
(HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a
Hsc ((HscEnv -> WarningMessages -> IO (HscEnv, WarningMessages))
 -> Hsc HscEnv)
-> (HscEnv -> WarningMessages -> IO (HscEnv, WarningMessages))
-> Hsc HscEnv
forall a b. (a -> b) -> a -> b
$ \e :: HscEnv
e w :: WarningMessages
w -> (HscEnv, WarningMessages) -> IO (HscEnv, WarningMessages)
forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv
e, WarningMessages
w)
            IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ do
              -- Validate Scopes
              case Map FastString (HieAST Int) -> [SDoc]
forall a. Map FastString (HieAST a) -> [SDoc]
validateScopes (Map FastString (HieAST Int) -> [SDoc])
-> Map FastString (HieAST Int) -> [SDoc]
forall a b. (a -> b) -> a -> b
$ HieASTs Int -> Map FastString (HieAST Int)
forall a. HieASTs a -> Map FastString (HieAST a)
getAsts (HieASTs Int -> Map FastString (HieAST Int))
-> HieASTs Int -> Map FastString (HieAST Int)
forall a b. (a -> b) -> a -> b
$ HieFile -> HieASTs Int
hie_asts HieFile
hieFile of
                  [] -> DynFlags -> SDoc -> IO ()
putMsg DynFlags
dflags (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "Got valid scopes"
                  xs :: [SDoc]
xs -> do
                    DynFlags -> SDoc -> IO ()
putMsg DynFlags
dflags (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "Got invalid scopes"
                    (SDoc -> IO ()) -> [SDoc] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DynFlags -> SDoc -> IO ()
putMsg DynFlags
dflags) [SDoc]
xs
              -- Roundtrip testing
              NameCache
nc <- IORef NameCache -> IO NameCache
forall a. IORef a -> IO a
readIORef (IORef NameCache -> IO NameCache)
-> IORef NameCache -> IO NameCache
forall a b. (a -> b) -> a -> b
$ HscEnv -> IORef NameCache
hsc_NC HscEnv
hs_env
              (file' :: HieFileResult
file', _) <- NameCache -> String -> IO (HieFileResult, NameCache)
readHieFile NameCache
nc String
out_file
              case Diff HieFile
diffFile HieFile
hieFile (HieFileResult -> HieFile
hie_file_result HieFileResult
file') of
                [] ->
                  DynFlags -> SDoc -> IO ()
putMsg DynFlags
dflags (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "Got no roundtrip errors"
                xs :: [SDoc]
xs -> do
                  DynFlags -> SDoc -> IO ()
putMsg DynFlags
dflags (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "Got roundtrip errors"
                  (SDoc -> IO ()) -> [SDoc] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DynFlags -> SDoc -> IO ()
putMsg DynFlags
dflags) [SDoc]
xs
    RenamedStuff -> Hsc RenamedStuff
forall (m :: * -> *) a. Monad m => a -> m a
return RenamedStuff
rn_info


-- -----------------------------------------------------------------------------
-- | Rename and typecheck a module, additionally returning the renamed syntax
hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
                   -> IO (TcGblEnv, RenamedStuff)
hscTypecheckRename :: HscEnv
-> ModSummary -> HsParsedModule -> IO (TcGblEnv, RenamedStuff)
hscTypecheckRename hsc_env :: HscEnv
hsc_env mod_summary :: ModSummary
mod_summary rdr_module :: HsParsedModule
rdr_module = HscEnv
-> Hsc (TcGblEnv, RenamedStuff) -> IO (TcGblEnv, RenamedStuff)
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc (TcGblEnv, RenamedStuff) -> IO (TcGblEnv, RenamedStuff))
-> Hsc (TcGblEnv, RenamedStuff) -> IO (TcGblEnv, RenamedStuff)
forall a b. (a -> b) -> a -> b
$ do
    TcGblEnv
tc_result <- Bool -> ModSummary -> Maybe HsParsedModule -> Hsc TcGblEnv
hsc_typecheck Bool
True ModSummary
mod_summary (HsParsedModule -> Maybe HsParsedModule
forall a. a -> Maybe a
Just HsParsedModule
rdr_module)
    RenamedStuff
rn_info <- ModSummary -> TcGblEnv -> Hsc RenamedStuff
extract_renamed_stuff ModSummary
mod_summary TcGblEnv
tc_result
    (TcGblEnv, RenamedStuff) -> Hsc (TcGblEnv, RenamedStuff)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tc_result, RenamedStuff
rn_info)

-- | Rename and typecheck a module, but don't return the renamed syntax
hscTypecheck :: Bool -- ^ Keep renamed source?
             -> ModSummary -> Maybe HsParsedModule
             -> Hsc TcGblEnv
hscTypecheck :: Bool -> ModSummary -> Maybe HsParsedModule -> Hsc TcGblEnv
hscTypecheck keep_rn :: Bool
keep_rn mod_summary :: ModSummary
mod_summary mb_rdr_module :: Maybe HsParsedModule
mb_rdr_module = do
    TcGblEnv
tc_result <- Bool -> ModSummary -> Maybe HsParsedModule -> Hsc TcGblEnv
hsc_typecheck Bool
keep_rn ModSummary
mod_summary Maybe HsParsedModule
mb_rdr_module
    RenamedStuff
_ <- ModSummary -> TcGblEnv -> Hsc RenamedStuff
extract_renamed_stuff ModSummary
mod_summary TcGblEnv
tc_result
    TcGblEnv -> Hsc TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tc_result

hsc_typecheck :: Bool -- ^ Keep renamed source?
              -> ModSummary -> Maybe HsParsedModule
              -> Hsc TcGblEnv
hsc_typecheck :: Bool -> ModSummary -> Maybe HsParsedModule -> Hsc TcGblEnv
hsc_typecheck keep_rn :: Bool
keep_rn mod_summary :: ModSummary
mod_summary mb_rdr_module :: Maybe HsParsedModule
mb_rdr_module = do
    HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
    let hsc_src :: HscSource
hsc_src = ModSummary -> HscSource
ms_hsc_src ModSummary
mod_summary
        dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        outer_mod :: Module
outer_mod = ModSummary -> Module
ms_mod ModSummary
mod_summary
        mod_name :: ModuleName
mod_name = Module -> ModuleName
moduleName Module
outer_mod
        outer_mod' :: Module
outer_mod' = UnitId -> ModuleName -> Module
mkModule (DynFlags -> UnitId
thisPackage DynFlags
dflags) ModuleName
mod_name
        inner_mod :: Module
inner_mod = DynFlags -> ModuleName -> Module
canonicalizeHomeModule DynFlags
dflags ModuleName
mod_name
        src_filename :: String
src_filename  = ModSummary -> String
ms_hspp_file ModSummary
mod_summary
        real_loc :: RealSrcSpan
real_loc = RealSrcLoc -> RealSrcSpan
realSrcLocSpan (RealSrcLoc -> RealSrcSpan) -> RealSrcLoc -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
mkFastString String
src_filename) 1 1
        keep_rn' :: Bool
keep_rn' = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteHie DynFlags
dflags Bool -> Bool -> Bool
|| Bool
keep_rn
    MASSERT( moduleUnitId outer_mod == thisPackage dflags )
    if HscSource
hsc_src HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile Bool -> Bool -> Bool
&& Bool -> Bool
not (Module -> Bool
isHoleModule Module
inner_mod)
        then IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
-> Hsc TcGblEnv
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
 -> Hsc TcGblEnv)
-> IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
-> Hsc TcGblEnv
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Module
-> RealSrcSpan
-> IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
tcRnInstantiateSignature HscEnv
hsc_env Module
outer_mod' RealSrcSpan
real_loc
        else
         do HsParsedModule
hpm <- case Maybe HsParsedModule
mb_rdr_module of
                    Just hpm :: HsParsedModule
hpm -> HsParsedModule -> Hsc HsParsedModule
forall (m :: * -> *) a. Monad m => a -> m a
return HsParsedModule
hpm
                    Nothing -> ModSummary -> Hsc HsParsedModule
hscParse' ModSummary
mod_summary
            TcGblEnv
tc_result0 <- ModSummary -> Bool -> HsParsedModule -> Hsc TcGblEnv
tcRnModule' ModSummary
mod_summary Bool
keep_rn' HsParsedModule
hpm
            if HscSource
hsc_src HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile
                then do (iface :: ModIface
iface, _, _) <- IO (ModIface, Bool, ModDetails) -> Hsc (ModIface, Bool, ModDetails)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ModIface, Bool, ModDetails)
 -> Hsc (ModIface, Bool, ModDetails))
-> IO (ModIface, Bool, ModDetails)
-> Hsc (ModIface, Bool, ModDetails)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> TcGblEnv -> Maybe Fingerprint -> IO (ModIface, Bool, ModDetails)
hscSimpleIface HscEnv
hsc_env TcGblEnv
tc_result0 Maybe Fingerprint
forall a. Maybe a
Nothing
                        IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
-> Hsc TcGblEnv
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
 -> Hsc TcGblEnv)
-> IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
-> Hsc TcGblEnv
forall a b. (a -> b) -> a -> b
$
                            HscEnv
-> HsParsedModule
-> TcGblEnv
-> ModIface
-> IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
tcRnMergeSignatures HscEnv
hsc_env HsParsedModule
hpm TcGblEnv
tc_result0 ModIface
iface
                else TcGblEnv -> Hsc TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tc_result0

-- wrapper around tcRnModule to handle safe haskell extras
tcRnModule' :: ModSummary -> Bool -> HsParsedModule
            -> Hsc TcGblEnv
tcRnModule' :: ModSummary -> Bool -> HsParsedModule -> Hsc TcGblEnv
tcRnModule' sum :: ModSummary
sum save_rn_syntax :: Bool
save_rn_syntax mod :: HsParsedModule
mod = do
    HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
    DynFlags
dflags   <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

    TcGblEnv
tcg_res <- {-# SCC "Typecheck-Rename" #-}
               IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
-> Hsc TcGblEnv
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
 -> Hsc TcGblEnv)
-> IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
-> Hsc TcGblEnv
forall a b. (a -> b) -> a -> b
$
                   HscEnv
-> ModSummary
-> Bool
-> HsParsedModule
-> IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
tcRnModule HscEnv
hsc_env ModSummary
sum
                     Bool
save_rn_syntax HsParsedModule
mod

    -- See Note [Safe Haskell Overlapping Instances Implementation]
    -- although this is used for more than just that failure case.
    (tcSafeOK :: Bool
tcSafeOK, whyUnsafe :: WarningMessages
whyUnsafe) <- IO (Bool, WarningMessages) -> Hsc (Bool, WarningMessages)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Bool, WarningMessages) -> Hsc (Bool, WarningMessages))
-> IO (Bool, WarningMessages) -> Hsc (Bool, WarningMessages)
forall a b. (a -> b) -> a -> b
$ IORef (Bool, WarningMessages) -> IO (Bool, WarningMessages)
forall a. IORef a -> IO a
readIORef (TcGblEnv -> IORef (Bool, WarningMessages)
tcg_safeInfer TcGblEnv
tcg_res)
    let allSafeOK :: Bool
allSafeOK = DynFlags -> Bool
safeInferred DynFlags
dflags Bool -> Bool -> Bool
&& Bool
tcSafeOK

    -- end of the safe haskell line, how to respond to user?
    TcGblEnv
res <- if Bool -> Bool
not (DynFlags -> Bool
safeHaskellOn DynFlags
dflags)
                Bool -> Bool -> Bool
|| (DynFlags -> Bool
safeInferOn DynFlags
dflags Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
allSafeOK)
             -- if safe Haskell off or safe infer failed, mark unsafe
             then TcGblEnv -> WarningMessages -> Hsc TcGblEnv
markUnsafeInfer TcGblEnv
tcg_res WarningMessages
whyUnsafe

             -- module (could be) safe, throw warning if needed
             else do
                 TcGblEnv
tcg_res' <- TcGblEnv -> Hsc TcGblEnv
hscCheckSafeImports TcGblEnv
tcg_res
                 Bool
safe <- IO Bool -> Hsc Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Hsc Bool) -> IO Bool -> Hsc Bool
forall a b. (a -> b) -> a -> b
$ (Bool, WarningMessages) -> Bool
forall a b. (a, b) -> a
fst ((Bool, WarningMessages) -> Bool)
-> IO (Bool, WarningMessages) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Bool, WarningMessages) -> IO (Bool, WarningMessages)
forall a. IORef a -> IO a
readIORef (TcGblEnv -> IORef (Bool, WarningMessages)
tcg_safeInfer TcGblEnv
tcg_res')
                 Bool -> Hsc () -> Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
safe (Hsc () -> Hsc ()) -> Hsc () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ do
                   case WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnSafe DynFlags
dflags of
                     True
                       | DynFlags -> SafeHaskellMode
safeHaskell DynFlags
dflags SafeHaskellMode -> SafeHaskellMode -> Bool
forall a. Eq a => a -> a -> Bool
== SafeHaskellMode
Sf_Safe -> () -> Hsc ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                       | Bool
otherwise -> (WarningMessages -> Hsc ()
logWarnings (WarningMessages -> Hsc ()) -> WarningMessages -> Hsc ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> WarningMessages
forall a. a -> Bag a
unitBag (ErrMsg -> WarningMessages) -> ErrMsg -> WarningMessages
forall a b. (a -> b) -> a -> b
$
                              WarnReason -> ErrMsg -> ErrMsg
makeIntoWarning (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnSafe) (ErrMsg -> ErrMsg) -> ErrMsg -> ErrMsg
forall a b. (a -> b) -> a -> b
$
                              DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainWarnMsg DynFlags
dflags (DynFlags -> SrcSpan
warnSafeOnLoc DynFlags
dflags) (SDoc -> ErrMsg) -> SDoc -> ErrMsg
forall a b. (a -> b) -> a -> b
$
                              TcGblEnv -> SDoc
errSafe TcGblEnv
tcg_res')
                     False | DynFlags -> SafeHaskellMode
safeHaskell DynFlags
dflags SafeHaskellMode -> SafeHaskellMode -> Bool
forall a. Eq a => a -> a -> Bool
== SafeHaskellMode
Sf_Trustworthy Bool -> Bool -> Bool
&&
                             WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnTrustworthySafe DynFlags
dflags ->
                             (WarningMessages -> Hsc ()
logWarnings (WarningMessages -> Hsc ()) -> WarningMessages -> Hsc ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> WarningMessages
forall a. a -> Bag a
unitBag (ErrMsg -> WarningMessages) -> ErrMsg -> WarningMessages
forall a b. (a -> b) -> a -> b
$
                              WarnReason -> ErrMsg -> ErrMsg
makeIntoWarning (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnTrustworthySafe) (ErrMsg -> ErrMsg) -> ErrMsg -> ErrMsg
forall a b. (a -> b) -> a -> b
$
                              DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainWarnMsg DynFlags
dflags (DynFlags -> SrcSpan
trustworthyOnLoc DynFlags
dflags) (SDoc -> ErrMsg) -> SDoc -> ErrMsg
forall a b. (a -> b) -> a -> b
$
                              TcGblEnv -> SDoc
errTwthySafe TcGblEnv
tcg_res')
                     False -> () -> Hsc ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                 TcGblEnv -> Hsc TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_res'

    -- apply plugins to the type checking result


    TcGblEnv -> Hsc TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
res
  where
    pprMod :: TcGblEnv -> SDoc
pprMod t :: TcGblEnv
t  = ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModuleName -> SDoc) -> ModuleName -> SDoc
forall a b. (a -> b) -> a -> b
$ Module -> ModuleName
moduleName (Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ TcGblEnv -> Module
tcg_mod TcGblEnv
t
    errSafe :: TcGblEnv -> SDoc
errSafe t :: TcGblEnv
t = SDoc -> SDoc
quotes (TcGblEnv -> SDoc
pprMod TcGblEnv
t) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "has been inferred as safe!"
    errTwthySafe :: TcGblEnv -> SDoc
errTwthySafe t :: TcGblEnv
t = SDoc -> SDoc
quotes (TcGblEnv -> SDoc
pprMod TcGblEnv
t)
      SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is marked as Trustworthy but has been inferred as safe!"

-- | Convert a typechecked module to Core
hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
hscDesugar hsc_env :: HscEnv
hsc_env mod_summary :: ModSummary
mod_summary tc_result :: TcGblEnv
tc_result =
    HscEnv -> Hsc ModGuts -> IO ModGuts
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc ModGuts -> IO ModGuts) -> Hsc ModGuts -> IO ModGuts
forall a b. (a -> b) -> a -> b
$ ModLocation -> TcGblEnv -> Hsc ModGuts
hscDesugar' (ModSummary -> ModLocation
ms_location ModSummary
mod_summary) TcGblEnv
tc_result

hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts
hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts
hscDesugar' mod_location :: ModLocation
mod_location tc_result :: TcGblEnv
tc_result = do
    HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
    ModGuts
r <- IO ((WarningMessages, WarningMessages), Maybe ModGuts)
-> Hsc ModGuts
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO ((WarningMessages, WarningMessages), Maybe ModGuts)
 -> Hsc ModGuts)
-> IO ((WarningMessages, WarningMessages), Maybe ModGuts)
-> Hsc ModGuts
forall a b. (a -> b) -> a -> b
$
      {-# SCC "deSugar" #-}
      HscEnv
-> ModLocation
-> TcGblEnv
-> IO ((WarningMessages, WarningMessages), Maybe ModGuts)
deSugar HscEnv
hsc_env ModLocation
mod_location TcGblEnv
tc_result

    -- always check -Werror after desugaring, this is the last opportunity for
    -- warnings to arise before the backend.
    Hsc ()
handleWarnings
    ModGuts -> Hsc ModGuts
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
r

-- | Make a 'ModDetails' from the results of typechecking. Used when
-- typechecking only, as opposed to full compilation.
makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails
makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails
makeSimpleDetails hsc_env :: HscEnv
hsc_env tc_result :: TcGblEnv
tc_result = HscEnv -> TcGblEnv -> IO ModDetails
mkBootModDetailsTc HscEnv
hsc_env TcGblEnv
tc_result


{- **********************************************************************
%*                                                                      *
                The main compiler pipeline
%*                                                                      *
%********************************************************************* -}

{-
                   --------------------------------
                        The compilation proper
                   --------------------------------

It's the task of the compilation proper to compile Haskell, hs-boot and core
files to either byte-code, hard-code (C, asm, LLVM, etc.) or to nothing at all
(the module is still parsed and type-checked. This feature is mostly used by
IDE's and the likes). Compilation can happen in either 'one-shot', 'batch',
'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch'
mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode
targets byte-code.

The modes are kept separate because of their different types and meanings:

 * In 'one-shot' mode, we're only compiling a single file and can therefore
 discard the new ModIface and ModDetails. This is also the reason it only
 targets hard-code; compiling to byte-code or nothing doesn't make sense when
 we discard the result.

 * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface
 and ModDetails. 'Batch' mode doesn't target byte-code since that require us to
 return the newly compiled byte-code.

 * 'Nothing' mode has exactly the same type as 'batch' mode but they're still
 kept separate. This is because compiling to nothing is fairly special: We
 don't output any interface files, we don't run the simplifier and we don't
 generate any code.

 * 'Interactive' mode is similar to 'batch' mode except that we return the
 compiled byte-code together with the ModIface and ModDetails.

Trying to compile a hs-boot file to byte-code will result in a run-time error.
This is the only thing that isn't caught by the type-system.
-}


type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModSummary -> IO ()

-- | This function runs GHC's frontend with recompilation
-- avoidance. Specifically, it checks if recompilation is needed,
-- and if it is, it parses and typechecks the input module.
-- It does not write out the results of typechecking (See
-- compileOne and hscIncrementalCompile).
hscIncrementalFrontend :: Bool -- always do basic recompilation check?
                       -> Maybe TcGblEnv
                       -> Maybe Messager
                       -> ModSummary
                       -> SourceModified
                       -> Maybe ModIface  -- Old interface, if available
                       -> (Int,Int)       -- (i,n) = module i of n (for msgs)
                       -> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))

hscIncrementalFrontend :: Bool
-> Maybe TcGblEnv
-> Maybe Messager
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int, Int)
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
hscIncrementalFrontend
  always_do_basic_recompilation_check :: Bool
always_do_basic_recompilation_check m_tc_result :: Maybe TcGblEnv
m_tc_result
  mHscMessage :: Maybe Messager
mHscMessage mod_summary :: ModSummary
mod_summary source_modified :: SourceModified
source_modified mb_old_iface :: Maybe ModIface
mb_old_iface mod_index :: (Int, Int)
mod_index
    = do
    HscEnv
hsc_env <- Hsc HscEnv
getHscEnv

    let msg :: RecompileRequired -> IO ()
msg what :: RecompileRequired
what = case Maybe Messager
mHscMessage of
                   Just hscMessage :: Messager
hscMessage -> Messager
hscMessage HscEnv
hsc_env (Int, Int)
mod_index RecompileRequired
what ModSummary
mod_summary
                   Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        skip :: a -> m (Either a b)
skip iface :: a
iface = do
            IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ RecompileRequired -> IO ()
msg RecompileRequired
UpToDate
            Either a b -> m (Either a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a b -> m (Either a b)) -> Either a b -> m (Either a b)
forall a b. (a -> b) -> a -> b
$ a -> Either a b
forall a b. a -> Either a b
Left a
iface

        compile :: b -> RecompileRequired -> Hsc (Either a (FrontendResult, b))
compile mb_old_hash :: b
mb_old_hash reason :: RecompileRequired
reason = do
            IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ RecompileRequired -> IO ()
msg RecompileRequired
reason
            FrontendResult
result <- ModSummary -> Hsc FrontendResult
genericHscFrontend ModSummary
mod_summary
            Either a (FrontendResult, b) -> Hsc (Either a (FrontendResult, b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a (FrontendResult, b)
 -> Hsc (Either a (FrontendResult, b)))
-> Either a (FrontendResult, b)
-> Hsc (Either a (FrontendResult, b))
forall a b. (a -> b) -> a -> b
$ (FrontendResult, b) -> Either a (FrontendResult, b)
forall a b. b -> Either a b
Right (FrontendResult
result, b
mb_old_hash)

        stable :: Bool
stable = case SourceModified
source_modified of
                     SourceUnmodifiedAndStable -> Bool
True
                     _                         -> Bool
False

    case Maybe TcGblEnv
m_tc_result of
         Just tc_result :: TcGblEnv
tc_result
          | Bool -> Bool
not Bool
always_do_basic_recompilation_check ->
             Either ModIface (FrontendResult, Maybe Fingerprint)
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ModIface (FrontendResult, Maybe Fingerprint)
 -> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint)))
-> Either ModIface (FrontendResult, Maybe Fingerprint)
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
forall a b. (a -> b) -> a -> b
$ (FrontendResult, Maybe Fingerprint)
-> Either ModIface (FrontendResult, Maybe Fingerprint)
forall a b. b -> Either a b
Right (TcGblEnv -> FrontendResult
FrontendTypecheck TcGblEnv
tc_result, Maybe Fingerprint
forall a. Maybe a
Nothing)
         _ -> do
            (recomp_reqd :: RecompileRequired
recomp_reqd, mb_checked_iface :: Maybe ModIface
mb_checked_iface)
                <- {-# SCC "checkOldIface" #-}
                   IO (RecompileRequired, Maybe ModIface)
-> Hsc (RecompileRequired, Maybe ModIface)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (RecompileRequired, Maybe ModIface)
 -> Hsc (RecompileRequired, Maybe ModIface))
-> IO (RecompileRequired, Maybe ModIface)
-> Hsc (RecompileRequired, Maybe ModIface)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> IO (RecompileRequired, Maybe ModIface)
checkOldIface HscEnv
hsc_env ModSummary
mod_summary
                                SourceModified
source_modified Maybe ModIface
mb_old_iface
            -- save the interface that comes back from checkOldIface.
            -- In one-shot mode we don't have the old iface until this
            -- point, when checkOldIface reads it from the disk.
            let mb_old_hash :: Maybe Fingerprint
mb_old_hash = (ModIface -> Fingerprint) -> Maybe ModIface -> Maybe Fingerprint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ModIface -> Fingerprint
mi_iface_hash Maybe ModIface
mb_checked_iface

            case Maybe ModIface
mb_checked_iface of
                Just iface :: ModIface
iface | Bool -> Bool
not (RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp_reqd) ->
                    -- If the module used TH splices when it was last
                    -- compiled, then the recompilation check is not
                    -- accurate enough (#481) and we must ignore
                    -- it.  However, if the module is stable (none of
                    -- the modules it depends on, directly or
                    -- indirectly, changed), then we *can* skip
                    -- recompilation. This is why the SourceModified
                    -- type contains SourceUnmodifiedAndStable, and
                    -- it's pretty important: otherwise ghc --make
                    -- would always recompile TH modules, even if
                    -- nothing at all has changed. Stability is just
                    -- the same check that make is doing for us in
                    -- one-shot mode.
                    case Maybe TcGblEnv
m_tc_result of
                    Nothing
                     | ModIface -> Bool
mi_used_th ModIface
iface Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
stable ->
                        Maybe Fingerprint
-> RecompileRequired
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
forall b a.
b -> RecompileRequired -> Hsc (Either a (FrontendResult, b))
compile Maybe Fingerprint
mb_old_hash (String -> RecompileRequired
RecompBecause "TH")
                    _ ->
                        ModIface
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
forall (m :: * -> *) a b. MonadIO m => a -> m (Either a b)
skip ModIface
iface
                _ ->
                    case Maybe TcGblEnv
m_tc_result of
                    Nothing -> Maybe Fingerprint
-> RecompileRequired
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
forall b a.
b -> RecompileRequired -> Hsc (Either a (FrontendResult, b))
compile Maybe Fingerprint
mb_old_hash RecompileRequired
recomp_reqd
                    Just tc_result :: TcGblEnv
tc_result ->
                        Either ModIface (FrontendResult, Maybe Fingerprint)
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ModIface (FrontendResult, Maybe Fingerprint)
 -> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint)))
-> Either ModIface (FrontendResult, Maybe Fingerprint)
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
forall a b. (a -> b) -> a -> b
$ (FrontendResult, Maybe Fingerprint)
-> Either ModIface (FrontendResult, Maybe Fingerprint)
forall a b. b -> Either a b
Right (TcGblEnv -> FrontendResult
FrontendTypecheck TcGblEnv
tc_result, Maybe Fingerprint
mb_old_hash)

genericHscFrontend :: ModSummary -> Hsc FrontendResult
genericHscFrontend :: ModSummary -> Hsc FrontendResult
genericHscFrontend mod_summary :: ModSummary
mod_summary =
  (Hooks -> Maybe (ModSummary -> Hsc FrontendResult))
-> (ModSummary -> Hsc FrontendResult)
-> Hsc (ModSummary -> Hsc FrontendResult)
forall (f :: * -> *) a.
(Functor f, HasDynFlags f) =>
(Hooks -> Maybe a) -> a -> f a
getHooked Hooks -> Maybe (ModSummary -> Hsc FrontendResult)
hscFrontendHook ModSummary -> Hsc FrontendResult
genericHscFrontend' Hsc (ModSummary -> Hsc FrontendResult)
-> ((ModSummary -> Hsc FrontendResult) -> Hsc FrontendResult)
-> Hsc FrontendResult
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((ModSummary -> Hsc FrontendResult)
-> ModSummary -> Hsc FrontendResult
forall a b. (a -> b) -> a -> b
$ ModSummary
mod_summary)

genericHscFrontend' :: ModSummary -> Hsc FrontendResult
genericHscFrontend' :: ModSummary -> Hsc FrontendResult
genericHscFrontend' mod_summary :: ModSummary
mod_summary
    = TcGblEnv -> FrontendResult
FrontendTypecheck (TcGblEnv -> FrontendResult) -> Hsc TcGblEnv -> Hsc FrontendResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ModSummary -> Hsc TcGblEnv
hscFileFrontEnd ModSummary
mod_summary

--------------------------------------------------------------
-- Compilers
--------------------------------------------------------------

-- Compile Haskell/boot in OneShot mode.
hscIncrementalCompile :: Bool
                      -> Maybe TcGblEnv
                      -> Maybe Messager
                      -> HscEnv
                      -> ModSummary
                      -> SourceModified
                      -> Maybe ModIface
                      -> (Int,Int)
                      -- HomeModInfo does not contain linkable, since we haven't
                      -- code-genned yet
                      -> IO (HscStatus, HomeModInfo)
hscIncrementalCompile :: Bool
-> Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int, Int)
-> IO (HscStatus, HomeModInfo)
hscIncrementalCompile always_do_basic_recompilation_check :: Bool
always_do_basic_recompilation_check m_tc_result :: Maybe TcGblEnv
m_tc_result
    mHscMessage :: Maybe Messager
mHscMessage hsc_env' :: HscEnv
hsc_env' mod_summary :: ModSummary
mod_summary source_modified :: SourceModified
source_modified mb_old_iface :: Maybe ModIface
mb_old_iface mod_index :: (Int, Int)
mod_index
  = do
    DynFlags
dflags <- HscEnv -> DynFlags -> IO DynFlags
initializePlugins HscEnv
hsc_env' (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env')
    let hsc_env'' :: HscEnv
hsc_env'' = HscEnv
hsc_env' { hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags }

    -- One-shot mode needs a knot-tying mutable variable for interface
    -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var.
    -- See also Note [hsc_type_env_var hack]
    IORef TypeEnv
type_env_var <- TypeEnv -> IO (IORef TypeEnv)
forall a. a -> IO (IORef a)
newIORef TypeEnv
forall a. NameEnv a
emptyNameEnv
    let mod :: Module
mod = ModSummary -> Module
ms_mod ModSummary
mod_summary
        hsc_env :: HscEnv
hsc_env | GhcMode -> Bool
isOneShot (DynFlags -> GhcMode
ghcMode (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env''))
                = HscEnv
hsc_env'' { hsc_type_env_var :: Maybe (Module, IORef TypeEnv)
hsc_type_env_var = (Module, IORef TypeEnv) -> Maybe (Module, IORef TypeEnv)
forall a. a -> Maybe a
Just (Module
mod, IORef TypeEnv
type_env_var) }
                | Bool
otherwise
                = HscEnv
hsc_env''

    -- NB: enter Hsc monad here so that we don't bail out early with
    -- -Werror on typechecker warnings; we also want to run the desugarer
    -- to get those warnings too. (But we'll always exit at that point
    -- because the desugarer runs ioMsgMaybe.)
    HscEnv
-> Hsc (HscStatus, HomeModInfo) -> IO (HscStatus, HomeModInfo)
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc (HscStatus, HomeModInfo) -> IO (HscStatus, HomeModInfo))
-> Hsc (HscStatus, HomeModInfo) -> IO (HscStatus, HomeModInfo)
forall a b. (a -> b) -> a -> b
$ do
    Either ModIface (FrontendResult, Maybe Fingerprint)
e <- Bool
-> Maybe TcGblEnv
-> Maybe Messager
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int, Int)
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
hscIncrementalFrontend Bool
always_do_basic_recompilation_check Maybe TcGblEnv
m_tc_result Maybe Messager
mHscMessage
            ModSummary
mod_summary SourceModified
source_modified Maybe ModIface
mb_old_iface (Int, Int)
mod_index
    case Either ModIface (FrontendResult, Maybe Fingerprint)
e of
        -- We didn't need to do any typechecking; the old interface
        -- file on disk was good enough.
        Left iface :: ModIface
iface -> do
            -- Knot tying!  See Note [Knot-tying typecheckIface]
            HomeModInfo
hmi <- IO HomeModInfo -> Hsc HomeModInfo
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HomeModInfo -> Hsc HomeModInfo)
-> ((HomeModInfo -> IO HomeModInfo) -> IO HomeModInfo)
-> (HomeModInfo -> IO HomeModInfo)
-> Hsc HomeModInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HomeModInfo -> IO HomeModInfo) -> IO HomeModInfo
forall a. (a -> IO a) -> IO a
fixIO ((HomeModInfo -> IO HomeModInfo) -> Hsc HomeModInfo)
-> (HomeModInfo -> IO HomeModInfo) -> Hsc HomeModInfo
forall a b. (a -> b) -> a -> b
$ \hmi' :: HomeModInfo
hmi' -> do
                let hsc_env' :: HscEnv
hsc_env' =
                        HscEnv
hsc_env {
                            hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env)
                                        (ModSummary -> ModuleName
ms_mod_name ModSummary
mod_summary) HomeModInfo
hmi'
                        }
                -- NB: This result is actually not that useful
                -- in one-shot mode, since we're not going to do
                -- any further typechecking.  It's much more useful
                -- in make mode, since this HMI will go into the HPT.
                ModDetails
details <- HscEnv -> ModIface -> IO ModDetails
genModDetails HscEnv
hsc_env' ModIface
iface
                HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return $WHomeModInfo :: ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo{
                    hm_details :: ModDetails
hm_details = ModDetails
details,
                    hm_iface :: ModIface
hm_iface = ModIface
iface,
                    hm_linkable :: Maybe Linkable
hm_linkable = Maybe Linkable
forall a. Maybe a
Nothing }
            (HscStatus, HomeModInfo) -> Hsc (HscStatus, HomeModInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (HscStatus
HscUpToDate, HomeModInfo
hmi)
        -- We finished type checking.  (mb_old_hash is the hash of
        -- the interface that existed on disk; it's possible we had
        -- to retypecheck but the resulting interface is exactly
        -- the same.)
        Right (FrontendTypecheck tc_result :: TcGblEnv
tc_result, mb_old_hash :: Maybe Fingerprint
mb_old_hash) ->
            ModSummary
-> TcGblEnv -> Maybe Fingerprint -> Hsc (HscStatus, HomeModInfo)
finish ModSummary
mod_summary TcGblEnv
tc_result Maybe Fingerprint
mb_old_hash

-- Runs the post-typechecking frontend (desugar and simplify),
-- and then generates and writes out the final interface. We want
-- to write the interface AFTER simplification so we can get
-- as up-to-date and good unfoldings and other info as possible
-- in the interface file.
finish :: ModSummary
       -> TcGblEnv
       -> Maybe Fingerprint
       -> Hsc (HscStatus, HomeModInfo)
finish :: ModSummary
-> TcGblEnv -> Maybe Fingerprint -> Hsc (HscStatus, HomeModInfo)
finish summary :: ModSummary
summary tc_result :: TcGblEnv
tc_result mb_old_hash :: Maybe Fingerprint
mb_old_hash = do
  HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
  let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
      target :: HscTarget
target = DynFlags -> HscTarget
hscTarget DynFlags
dflags
      hsc_src :: HscSource
hsc_src = ModSummary -> HscSource
ms_hsc_src ModSummary
summary
      should_desugar :: Bool
should_desugar =
        ModSummary -> Module
ms_mod ModSummary
summary Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
/= Module
gHC_PRIM Bool -> Bool -> Bool
&& HscSource
hsc_src HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsSrcFile
      mk_simple_iface :: Hsc (ModIface, Bool, ModDetails, HscStatus)
mk_simple_iface = do
        let hsc_status :: HscStatus
hsc_status =
              case (HscTarget
target, HscSource
hsc_src) of
                (HscNothing, _) -> HscStatus
HscNotGeneratingCode
                (_, HsBootFile) -> HscStatus
HscUpdateBoot
                (_, HsigFile) -> HscStatus
HscUpdateSig
                _ -> String -> HscStatus
forall a. String -> a
panic "finish"
        (iface :: ModIface
iface, no_change :: Bool
no_change, details :: ModDetails
details) <- IO (ModIface, Bool, ModDetails) -> Hsc (ModIface, Bool, ModDetails)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ModIface, Bool, ModDetails)
 -> Hsc (ModIface, Bool, ModDetails))
-> IO (ModIface, Bool, ModDetails)
-> Hsc (ModIface, Bool, ModDetails)
forall a b. (a -> b) -> a -> b
$
          HscEnv
-> TcGblEnv -> Maybe Fingerprint -> IO (ModIface, Bool, ModDetails)
hscSimpleIface HscEnv
hsc_env TcGblEnv
tc_result Maybe Fingerprint
mb_old_hash
        (ModIface, Bool, ModDetails, HscStatus)
-> Hsc (ModIface, Bool, ModDetails, HscStatus)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface
iface, Bool
no_change, ModDetails
details, HscStatus
hsc_status)
  (iface :: ModIface
iface, no_change :: Bool
no_change, details :: ModDetails
details, hsc_status :: HscStatus
hsc_status) <-
    -- we usually desugar even when we are not generating code, otherwise
    -- we would miss errors thrown by the desugaring (see #10600). The only
    -- exceptions are when the Module is Ghc.Prim or when
    -- it is not a HsSrcFile Module.
    if Bool
should_desugar
      then do
        ModGuts
desugared_guts0 <- ModLocation -> TcGblEnv -> Hsc ModGuts
hscDesugar' (ModSummary -> ModLocation
ms_location ModSummary
summary) TcGblEnv
tc_result
        if HscTarget
target HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
== HscTarget
HscNothing
          -- We are not generating code, so we can skip simplification
          -- and generate a simple interface.
          then Hsc (ModIface, Bool, ModDetails, HscStatus)
mk_simple_iface
          else do
            [String]
plugins <- IO [String] -> Hsc [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> Hsc [String]) -> IO [String] -> Hsc [String]
forall a b. (a -> b) -> a -> b
$ IORef [String] -> IO [String]
forall a. IORef a -> IO a
readIORef (TcGblEnv -> IORef [String]
tcg_th_coreplugins TcGblEnv
tc_result)
            ModGuts
desugared_guts <- [String] -> ModGuts -> Hsc ModGuts
hscSimplify' [String]
plugins ModGuts
desugared_guts0
            (iface :: ModIface
iface, no_change :: Bool
no_change, details :: ModDetails
details, cgguts :: CgGuts
cgguts) <-
              IO (ModIface, Bool, ModDetails, CgGuts)
-> Hsc (ModIface, Bool, ModDetails, CgGuts)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ModIface, Bool, ModDetails, CgGuts)
 -> Hsc (ModIface, Bool, ModDetails, CgGuts))
-> IO (ModIface, Bool, ModDetails, CgGuts)
-> Hsc (ModIface, Bool, ModDetails, CgGuts)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> ModGuts
-> Maybe Fingerprint
-> IO (ModIface, Bool, ModDetails, CgGuts)
hscNormalIface HscEnv
hsc_env ModGuts
desugared_guts Maybe Fingerprint
mb_old_hash
            (ModIface, Bool, ModDetails, HscStatus)
-> Hsc (ModIface, Bool, ModDetails, HscStatus)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface
iface, Bool
no_change, ModDetails
details, CgGuts -> ModSummary -> HscStatus
HscRecomp CgGuts
cgguts ModSummary
summary)
      else Hsc (ModIface, Bool, ModDetails, HscStatus)
mk_simple_iface
  IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
hscMaybeWriteIface DynFlags
dflags ModIface
iface Bool
no_change ModSummary
summary
  (HscStatus, HomeModInfo) -> Hsc (HscStatus, HomeModInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( HscStatus
hsc_status
    , $WHomeModInfo :: ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo
      {hm_details :: ModDetails
hm_details = ModDetails
details, hm_iface :: ModIface
hm_iface = ModIface
iface, hm_linkable :: Maybe Linkable
hm_linkable = Maybe Linkable
forall a. Maybe a
Nothing})

hscMaybeWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
hscMaybeWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
hscMaybeWriteIface dflags :: DynFlags
dflags iface :: ModIface
iface no_change :: Bool
no_change summary :: ModSummary
summary =
    let force_write_interface :: Bool
force_write_interface = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteInterface DynFlags
dflags
        write_interface :: Bool
write_interface = case DynFlags -> HscTarget
hscTarget DynFlags
dflags of
                            HscNothing      -> Bool
False
                            HscInterpreted  -> Bool
False
                            _               -> Bool
True
    in Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
write_interface Bool -> Bool -> Bool
|| Bool
force_write_interface) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
hscWriteIface DynFlags
dflags ModIface
iface Bool
no_change ModSummary
summary

--------------------------------------------------------------
-- NoRecomp handlers
--------------------------------------------------------------

-- NB: this must be knot-tied appropriately, see hscIncrementalCompile
genModDetails :: HscEnv -> ModIface -> IO ModDetails
genModDetails :: HscEnv -> ModIface -> IO ModDetails
genModDetails hsc_env :: HscEnv
hsc_env old_iface :: ModIface
old_iface
  = do
    ModDetails
new_details <- {-# SCC "tcRnIface" #-}
                   HscEnv -> IfG ModDetails -> IO ModDetails
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env (ModIface -> IfG ModDetails
typecheckIface ModIface
old_iface)
    HscEnv -> IO ()
dumpIfaceStats HscEnv
hsc_env
    ModDetails -> IO ModDetails
forall (m :: * -> *) a. Monad m => a -> m a
return ModDetails
new_details

--------------------------------------------------------------
-- Progress displayers.
--------------------------------------------------------------

oneShotMsg :: HscEnv -> RecompileRequired -> IO ()
oneShotMsg :: HscEnv -> RecompileRequired -> IO ()
oneShotMsg hsc_env :: HscEnv
hsc_env recomp :: RecompileRequired
recomp =
    case RecompileRequired
recomp of
        UpToDate ->
            DynFlags -> String -> IO ()
compilationProgressMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                   "compilation IS NOT required"
        _ ->
            () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

batchMsg :: Messager
batchMsg :: Messager
batchMsg hsc_env :: HscEnv
hsc_env mod_index :: (Int, Int)
mod_index recomp :: RecompileRequired
recomp mod_summary :: ModSummary
mod_summary =
    case RecompileRequired
recomp of
        MustCompile -> String -> String -> IO ()
showMsg "Compiling " ""
        UpToDate
            | DynFlags -> Int
verbosity (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 2 -> String -> String -> IO ()
showMsg "Skipping  " ""
            | Bool
otherwise -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        RecompBecause reason :: String
reason -> String -> String -> IO ()
showMsg "Compiling " (" [" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
reason String -> String -> String
forall a. [a] -> [a] -> [a]
++ "]")
    where
        dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        showMsg :: String -> String -> IO ()
showMsg msg :: String
msg reason :: String
reason =
            DynFlags -> String -> IO ()
compilationProgressMsg DynFlags
dflags (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            ((Int, Int) -> String
showModuleIndex (Int, Int)
mod_index String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> HscTarget -> Bool -> ModSummary -> String
showModMsg DynFlags
dflags (DynFlags -> HscTarget
hscTarget DynFlags
dflags)
                              (RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp) ModSummary
mod_summary)
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
reason

--------------------------------------------------------------
-- FrontEnds
--------------------------------------------------------------

-- | Given a 'ModSummary', parses and typechecks it, returning the
-- 'TcGblEnv' resulting from type-checking.
hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv
hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv
hscFileFrontEnd mod_summary :: ModSummary
mod_summary = Bool -> ModSummary -> Maybe HsParsedModule -> Hsc TcGblEnv
hscTypecheck Bool
False ModSummary
mod_summary Maybe HsParsedModule
forall a. Maybe a
Nothing

--------------------------------------------------------------
-- Safe Haskell
--------------------------------------------------------------

-- Note [Safe Haskell Trust Check]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Safe Haskell checks that an import is trusted according to the following
-- rules for an import of module M that resides in Package P:
--
--   * If M is recorded as Safe and all its trust dependencies are OK
--     then M is considered safe.
--   * If M is recorded as Trustworthy and P is considered trusted and
--     all M's trust dependencies are OK then M is considered safe.
--
-- By trust dependencies we mean that the check is transitive. So if
-- a module M that is Safe relies on a module N that is trustworthy,
-- importing module M will first check (according to the second case)
-- that N is trusted before checking M is trusted.
--
-- This is a minimal description, so please refer to the user guide
-- for more details. The user guide is also considered the authoritative
-- source in this matter, not the comments or code.


-- Note [Safe Haskell Inference]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Safe Haskell does Safe inference on modules that don't have any specific
-- safe haskell mode flag. The basic approach to this is:
--   * When deciding if we need to do a Safe language check, treat
--     an unmarked module as having -XSafe mode specified.
--   * For checks, don't throw errors but return them to the caller.
--   * Caller checks if there are errors:
--     * For modules explicitly marked -XSafe, we throw the errors.
--     * For unmarked modules (inference mode), we drop the errors
--       and mark the module as being Unsafe.
--
-- It used to be that we only did safe inference on modules that had no Safe
-- Haskell flags, but now we perform safe inference on all modules as we want
-- to allow users to set the `-Wsafe`, `-Wunsafe` and
-- `-Wtrustworthy-safe` flags on Trustworthy and Unsafe modules so that a
-- user can ensure their assumptions are correct and see reasons for why a
-- module is safe or unsafe.
--
-- This is tricky as we must be careful when we should throw an error compared
-- to just warnings. For checking safe imports we manage it as two steps. First
-- we check any imports that are required to be safe, then we check all other
-- imports to see if we can infer them to be safe.


-- | Check that the safe imports of the module being compiled are valid.
-- If not we either issue a compilation error if the module is explicitly
-- using Safe Haskell, or mark the module as unsafe if we're in safe
-- inference mode.
hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
hscCheckSafeImports tcg_env :: TcGblEnv
tcg_env = do
    DynFlags
dflags   <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    TcGblEnv
tcg_env' <- TcGblEnv -> Hsc TcGblEnv
checkSafeImports TcGblEnv
tcg_env
    DynFlags -> TcGblEnv -> Hsc TcGblEnv
checkRULES DynFlags
dflags TcGblEnv
tcg_env'

  where
    checkRULES :: DynFlags -> TcGblEnv -> Hsc TcGblEnv
checkRULES dflags :: DynFlags
dflags tcg_env' :: TcGblEnv
tcg_env' = do
      case DynFlags -> Bool
safeLanguageOn DynFlags
dflags of
          True -> do
              -- XSafe: we nuke user written RULES
              WarningMessages -> Hsc ()
logWarnings (WarningMessages -> Hsc ()) -> WarningMessages -> Hsc ()
forall a b. (a -> b) -> a -> b
$ DynFlags
-> [GenLocated SrcSpan (RuleDecl GhcTc)] -> WarningMessages
forall pass.
DynFlags -> [GenLocated SrcSpan (RuleDecl pass)] -> WarningMessages
warns DynFlags
dflags (TcGblEnv -> [GenLocated SrcSpan (RuleDecl GhcTc)]
tcg_rules TcGblEnv
tcg_env')
              TcGblEnv -> Hsc TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env' { tcg_rules :: [GenLocated SrcSpan (RuleDecl GhcTc)]
tcg_rules = [] }
          False
                -- SafeInferred: user defined RULES, so not safe
              | DynFlags -> Bool
safeInferOn DynFlags
dflags Bool -> Bool -> Bool
&& Bool -> Bool
not ([GenLocated SrcSpan (RuleDecl GhcTc)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([GenLocated SrcSpan (RuleDecl GhcTc)] -> Bool)
-> [GenLocated SrcSpan (RuleDecl GhcTc)] -> Bool
forall a b. (a -> b) -> a -> b
$ TcGblEnv -> [GenLocated SrcSpan (RuleDecl GhcTc)]
tcg_rules TcGblEnv
tcg_env')
              -> TcGblEnv -> WarningMessages -> Hsc TcGblEnv
markUnsafeInfer TcGblEnv
tcg_env' (WarningMessages -> Hsc TcGblEnv)
-> WarningMessages -> Hsc TcGblEnv
forall a b. (a -> b) -> a -> b
$ DynFlags
-> [GenLocated SrcSpan (RuleDecl GhcTc)] -> WarningMessages
forall pass.
DynFlags -> [GenLocated SrcSpan (RuleDecl pass)] -> WarningMessages
warns DynFlags
dflags (TcGblEnv -> [GenLocated SrcSpan (RuleDecl GhcTc)]
tcg_rules TcGblEnv
tcg_env')

                -- Trustworthy OR SafeInferred: with no RULES
              | Bool
otherwise
              -> TcGblEnv -> Hsc TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env'

    warns :: DynFlags -> [GenLocated SrcSpan (RuleDecl pass)] -> WarningMessages
warns dflags :: DynFlags
dflags rules :: [GenLocated SrcSpan (RuleDecl pass)]
rules = [ErrMsg] -> WarningMessages
forall a. [a] -> Bag a
listToBag ([ErrMsg] -> WarningMessages) -> [ErrMsg] -> WarningMessages
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpan (RuleDecl pass) -> ErrMsg)
-> [GenLocated SrcSpan (RuleDecl pass)] -> [ErrMsg]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> GenLocated SrcSpan (RuleDecl pass) -> ErrMsg
forall pass.
DynFlags -> GenLocated SrcSpan (RuleDecl pass) -> ErrMsg
warnRules DynFlags
dflags) [GenLocated SrcSpan (RuleDecl pass)]
rules
    warnRules :: DynFlags -> GenLocated SrcSpan (RuleDecl pass) -> ErrMsg
warnRules dflags :: DynFlags
dflags (L loc :: SrcSpan
loc (HsRule { rd_name :: forall pass. RuleDecl pass -> Located (SourceText, FastString)
rd_name = Located (SourceText, FastString)
n })) =
        DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainWarnMsg DynFlags
dflags SrcSpan
loc (SDoc -> ErrMsg) -> SDoc -> ErrMsg
forall a b. (a -> b) -> a -> b
$
            String -> SDoc
text "Rule \"" SDoc -> SDoc -> SDoc
<> FastString -> SDoc
ftext ((SourceText, FastString) -> FastString
forall a b. (a, b) -> b
snd ((SourceText, FastString) -> FastString)
-> (SourceText, FastString) -> FastString
forall a b. (a -> b) -> a -> b
$ Located (SourceText, FastString)
-> SrcSpanLess (Located (SourceText, FastString))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (SourceText, FastString)
n) SDoc -> SDoc -> SDoc
<> String -> SDoc
text "\" ignored" SDoc -> SDoc -> SDoc
$+$
            String -> SDoc
text "User defined rules are disabled under Safe Haskell"
    warnRules _ (L _ (XRuleDecl _)) = String -> ErrMsg
forall a. String -> a
panic "hscCheckSafeImports"

-- | Validate that safe imported modules are actually safe.  For modules in the
-- HomePackage (the package the module we are compiling in resides) this just
-- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules
-- that reside in another package we also must check that the external package
-- is trusted. See the Note [Safe Haskell Trust Check] above for more
-- information.
--
-- The code for this is quite tricky as the whole algorithm is done in a few
-- distinct phases in different parts of the code base. See
-- RnNames.rnImportDecl for where package trust dependencies for a module are
-- collected and unioned.  Specifically see the Note [RnNames . Tracking Trust
-- Transitively] and the Note [RnNames . Trust Own Package].
checkSafeImports :: TcGblEnv -> Hsc TcGblEnv
checkSafeImports :: TcGblEnv -> Hsc TcGblEnv
checkSafeImports tcg_env :: TcGblEnv
tcg_env
    = do
        DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        [(Module, SrcSpan, Bool)]
imps <- ((Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, Bool))
-> [(Module, [ImportedModsVal])] -> Hsc [(Module, SrcSpan, Bool)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, Bool)
condense [(Module, [ImportedModsVal])]
imports'
        let (safeImps :: [(Module, SrcSpan, Bool)]
safeImps, regImps :: [(Module, SrcSpan, Bool)]
regImps) = ((Module, SrcSpan, Bool) -> Bool)
-> [(Module, SrcSpan, Bool)]
-> ([(Module, SrcSpan, Bool)], [(Module, SrcSpan, Bool)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(_,_,s :: Bool
s) -> Bool
s) [(Module, SrcSpan, Bool)]
imps

        -- We want to use the warning state specifically for detecting if safe
        -- inference has failed, so store and clear any existing warnings.
        WarningMessages
oldErrs <- Hsc WarningMessages
getWarnings
        Hsc ()
clearWarnings

        -- Check safe imports are correct
        Set InstalledUnitId
safePkgs <- [InstalledUnitId] -> Set InstalledUnitId
forall a. Ord a => [a] -> Set a
S.fromList ([InstalledUnitId] -> Set InstalledUnitId)
-> Hsc [InstalledUnitId] -> Hsc (Set InstalledUnitId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Module, SrcSpan, Bool) -> Hsc (Maybe InstalledUnitId))
-> [(Module, SrcSpan, Bool)] -> Hsc [InstalledUnitId]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (Module, SrcSpan, Bool) -> Hsc (Maybe InstalledUnitId)
forall a. (Module, SrcSpan, a) -> Hsc (Maybe InstalledUnitId)
checkSafe [(Module, SrcSpan, Bool)]
safeImps
        WarningMessages
safeErrs <- Hsc WarningMessages
getWarnings
        Hsc ()
clearWarnings

        -- Check non-safe imports are correct if inferring safety
        -- See the Note [Safe Haskell Inference]
        (infErrs :: WarningMessages
infErrs, infPkgs :: Set InstalledUnitId
infPkgs) <- case (DynFlags -> Bool
safeInferOn DynFlags
dflags) of
          False -> (WarningMessages, Set InstalledUnitId)
-> Hsc (WarningMessages, Set InstalledUnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return (WarningMessages
forall a. Bag a
emptyBag, Set InstalledUnitId
forall a. Set a
S.empty)
          True -> do Set InstalledUnitId
infPkgs <- [InstalledUnitId] -> Set InstalledUnitId
forall a. Ord a => [a] -> Set a
S.fromList ([InstalledUnitId] -> Set InstalledUnitId)
-> Hsc [InstalledUnitId] -> Hsc (Set InstalledUnitId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Module, SrcSpan, Bool) -> Hsc (Maybe InstalledUnitId))
-> [(Module, SrcSpan, Bool)] -> Hsc [InstalledUnitId]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (Module, SrcSpan, Bool) -> Hsc (Maybe InstalledUnitId)
forall a. (Module, SrcSpan, a) -> Hsc (Maybe InstalledUnitId)
checkSafe [(Module, SrcSpan, Bool)]
regImps
                     WarningMessages
infErrs <- Hsc WarningMessages
getWarnings
                     Hsc ()
clearWarnings
                     (WarningMessages, Set InstalledUnitId)
-> Hsc (WarningMessages, Set InstalledUnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return (WarningMessages
infErrs, Set InstalledUnitId
infPkgs)

        -- restore old errors
        WarningMessages -> Hsc ()
logWarnings WarningMessages
oldErrs

        case (WarningMessages -> Bool
forall a. Bag a -> Bool
isEmptyBag WarningMessages
safeErrs) of
          -- Failed safe check
          False -> IO TcGblEnv -> Hsc TcGblEnv
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TcGblEnv -> Hsc TcGblEnv)
-> (WarningMessages -> IO TcGblEnv)
-> WarningMessages
-> Hsc TcGblEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceError -> IO TcGblEnv
forall e a. Exception e => e -> IO a
throwIO (SourceError -> IO TcGblEnv)
-> (WarningMessages -> SourceError)
-> WarningMessages
-> IO TcGblEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WarningMessages -> SourceError
mkSrcErr (WarningMessages -> Hsc TcGblEnv)
-> WarningMessages -> Hsc TcGblEnv
forall a b. (a -> b) -> a -> b
$ WarningMessages
safeErrs

          -- Passed safe check
          True -> do
            let infPassed :: Bool
infPassed = WarningMessages -> Bool
forall a. Bag a -> Bool
isEmptyBag WarningMessages
infErrs
            TcGblEnv
tcg_env' <- case (Bool -> Bool
not Bool
infPassed) of
              True  -> TcGblEnv -> WarningMessages -> Hsc TcGblEnv
markUnsafeInfer TcGblEnv
tcg_env WarningMessages
infErrs
              False -> TcGblEnv -> Hsc TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env
            Bool -> Hsc () -> Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Bool
packageTrustOn DynFlags
dflags) (Hsc () -> Hsc ()) -> Hsc () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Set InstalledUnitId -> Hsc ()
checkPkgTrust Set InstalledUnitId
pkgReqs
            let newTrust :: ImportAvails
newTrust = DynFlags
-> Set InstalledUnitId
-> Set InstalledUnitId
-> Bool
-> ImportAvails
pkgTrustReqs DynFlags
dflags Set InstalledUnitId
safePkgs Set InstalledUnitId
infPkgs Bool
infPassed
            TcGblEnv -> Hsc TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env' { tcg_imports :: ImportAvails
tcg_imports = ImportAvails
impInfo ImportAvails -> ImportAvails -> ImportAvails
`plusImportAvails` ImportAvails
newTrust }

  where
    impInfo :: ImportAvails
impInfo  = TcGblEnv -> ImportAvails
tcg_imports TcGblEnv
tcg_env     -- ImportAvails
    imports :: ImportedMods
imports  = ImportAvails -> ImportedMods
imp_mods ImportAvails
impInfo        -- ImportedMods
    imports1 :: [(Module, [ImportedBy])]
imports1 = ImportedMods -> [(Module, [ImportedBy])]
forall a. ModuleEnv a -> [(Module, a)]
moduleEnvToList ImportedMods
imports -- (Module, [ImportedBy])
    imports' :: [(Module, [ImportedModsVal])]
imports' = ((Module, [ImportedBy]) -> (Module, [ImportedModsVal]))
-> [(Module, [ImportedBy])] -> [(Module, [ImportedModsVal])]
forall a b. (a -> b) -> [a] -> [b]
map (([ImportedBy] -> [ImportedModsVal])
-> (Module, [ImportedBy]) -> (Module, [ImportedModsVal])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ImportedBy] -> [ImportedModsVal]
importedByUser) [(Module, [ImportedBy])]
imports1 -- (Module, [ImportedModsVal])
    pkgReqs :: Set InstalledUnitId
pkgReqs  = ImportAvails -> Set InstalledUnitId
imp_trust_pkgs ImportAvails
impInfo  -- [UnitId]

    condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
    condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, Bool)
condense (_, [])   = String -> Hsc (Module, SrcSpan, Bool)
forall a. String -> a
panic "HscMain.condense: Pattern match failure!"
    condense (m :: Module
m, x :: ImportedModsVal
x:xs :: [ImportedModsVal]
xs) = do ImportedModsVal
imv <- (ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal)
-> ImportedModsVal -> [ImportedModsVal] -> Hsc ImportedModsVal
forall (m :: * -> *) a b.
Monad m =>
(a -> b -> m a) -> a -> [b] -> m a
foldlM ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
cond' ImportedModsVal
x [ImportedModsVal]
xs
                            (Module, SrcSpan, Bool) -> Hsc (Module, SrcSpan, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Module
m, ImportedModsVal -> SrcSpan
imv_span ImportedModsVal
imv, ImportedModsVal -> Bool
imv_is_safe ImportedModsVal
imv)

    -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)
    cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
    cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
cond' v1 :: ImportedModsVal
v1 v2 :: ImportedModsVal
v2
        | ImportedModsVal -> Bool
imv_is_safe ImportedModsVal
v1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= ImportedModsVal -> Bool
imv_is_safe ImportedModsVal
v2
        = do
            DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
            WarningMessages -> Hsc ImportedModsVal
forall (io :: * -> *) a. MonadIO io => WarningMessages -> io a
throwErrors (WarningMessages -> Hsc ImportedModsVal)
-> WarningMessages -> Hsc ImportedModsVal
forall a b. (a -> b) -> a -> b
$ ErrMsg -> WarningMessages
forall a. a -> Bag a
unitBag (ErrMsg -> WarningMessages) -> ErrMsg -> WarningMessages
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg DynFlags
dflags (ImportedModsVal -> SrcSpan
imv_span ImportedModsVal
v1)
              (String -> SDoc
text "Module" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ImportedModsVal -> ModuleName
imv_name ImportedModsVal
v1) SDoc -> SDoc -> SDoc
<+>
              (String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ "is imported both as a safe and unsafe import!"))
        | Bool
otherwise
        = ImportedModsVal -> Hsc ImportedModsVal
forall (m :: * -> *) a. Monad m => a -> m a
return ImportedModsVal
v1

    -- easier interface to work with
    checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe InstalledUnitId)
    checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe InstalledUnitId)
checkSafe (m :: Module
m, l :: SrcSpan
l, _) = (Maybe InstalledUnitId, Set InstalledUnitId)
-> Maybe InstalledUnitId
forall a b. (a, b) -> a
fst ((Maybe InstalledUnitId, Set InstalledUnitId)
 -> Maybe InstalledUnitId)
-> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
-> Hsc (Maybe InstalledUnitId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Module
-> SrcSpan -> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
hscCheckSafe' Module
m SrcSpan
l

    -- what pkg's to add to our trust requirements
    pkgTrustReqs :: DynFlags -> Set InstalledUnitId -> Set InstalledUnitId ->
          Bool -> ImportAvails
    pkgTrustReqs :: DynFlags
-> Set InstalledUnitId
-> Set InstalledUnitId
-> Bool
-> ImportAvails
pkgTrustReqs dflags :: DynFlags
dflags req :: Set InstalledUnitId
req inf :: Set InstalledUnitId
inf infPassed :: Bool
infPassed | DynFlags -> Bool
safeInferOn DynFlags
dflags
                                  Bool -> Bool -> Bool
&& Bool -> Bool
not (DynFlags -> Bool
safeHaskellModeEnabled DynFlags
dflags) Bool -> Bool -> Bool
&& Bool
infPassed
                                   = ImportAvails
emptyImportAvails {
                                       imp_trust_pkgs :: Set InstalledUnitId
imp_trust_pkgs = Set InstalledUnitId
req Set InstalledUnitId -> Set InstalledUnitId -> Set InstalledUnitId
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Set InstalledUnitId
inf
                                   }
    pkgTrustReqs dflags :: DynFlags
dflags _   _ _ | DynFlags -> SafeHaskellMode
safeHaskell DynFlags
dflags SafeHaskellMode -> SafeHaskellMode -> Bool
forall a. Eq a => a -> a -> Bool
== SafeHaskellMode
Sf_Unsafe
                         = ImportAvails
emptyImportAvails
    pkgTrustReqs _ req :: Set InstalledUnitId
req _ _ = ImportAvails
emptyImportAvails { imp_trust_pkgs :: Set InstalledUnitId
imp_trust_pkgs = Set InstalledUnitId
req }

-- | Check that a module is safe to import.
--
-- We return True to indicate the import is safe and False otherwise
-- although in the False case an exception may be thrown first.
hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool
hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool
hscCheckSafe hsc_env :: HscEnv
hsc_env m :: Module
m l :: SrcSpan
l = HscEnv -> Hsc Bool -> IO Bool
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc Bool -> IO Bool) -> Hsc Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
    DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    Set InstalledUnitId
pkgs <- (Maybe InstalledUnitId, Set InstalledUnitId) -> Set InstalledUnitId
forall a b. (a, b) -> b
snd ((Maybe InstalledUnitId, Set InstalledUnitId)
 -> Set InstalledUnitId)
-> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
-> Hsc (Set InstalledUnitId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Module
-> SrcSpan -> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
hscCheckSafe' Module
m SrcSpan
l
    Bool -> Hsc () -> Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Bool
packageTrustOn DynFlags
dflags) (Hsc () -> Hsc ()) -> Hsc () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Set InstalledUnitId -> Hsc ()
checkPkgTrust Set InstalledUnitId
pkgs
    WarningMessages
errs <- Hsc WarningMessages
getWarnings
    Bool -> Hsc Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Hsc Bool) -> Bool -> Hsc Bool
forall a b. (a -> b) -> a -> b
$ WarningMessages -> Bool
forall a. Bag a -> Bool
isEmptyBag WarningMessages
errs

-- | Return if a module is trusted and the pkgs it depends on to be trusted.
hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set InstalledUnitId)
hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set InstalledUnitId)
hscGetSafe hsc_env :: HscEnv
hsc_env m :: Module
m l :: SrcSpan
l = HscEnv
-> Hsc (Bool, Set InstalledUnitId)
-> IO (Bool, Set InstalledUnitId)
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc (Bool, Set InstalledUnitId) -> IO (Bool, Set InstalledUnitId))
-> Hsc (Bool, Set InstalledUnitId)
-> IO (Bool, Set InstalledUnitId)
forall a b. (a -> b) -> a -> b
$ do
    (self :: Maybe InstalledUnitId
self, pkgs :: Set InstalledUnitId
pkgs) <- Module
-> SrcSpan -> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
hscCheckSafe' Module
m SrcSpan
l
    Bool
good         <- WarningMessages -> Bool
forall a. Bag a -> Bool
isEmptyBag (WarningMessages -> Bool) -> Hsc WarningMessages -> Hsc Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Hsc WarningMessages
getWarnings
    Hsc ()
clearWarnings -- don't want them printed...
    let pkgs' :: Set InstalledUnitId
pkgs' | Just p :: InstalledUnitId
p <- Maybe InstalledUnitId
self = InstalledUnitId -> Set InstalledUnitId -> Set InstalledUnitId
forall a. Ord a => a -> Set a -> Set a
S.insert InstalledUnitId
p Set InstalledUnitId
pkgs
              | Bool
otherwise      = Set InstalledUnitId
pkgs
    (Bool, Set InstalledUnitId) -> Hsc (Bool, Set InstalledUnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
good, Set InstalledUnitId
pkgs')

-- | Is a module trusted? If not, throw or log errors depending on the type.
-- Return (regardless of trusted or not) if the trust type requires the modules
-- own package be trusted and a list of other packages required to be trusted
-- (these later ones haven't been checked) but the own package trust has been.
hscCheckSafe' :: Module -> SrcSpan
  -> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
hscCheckSafe' :: Module
-> SrcSpan -> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
hscCheckSafe' m :: Module
m l :: SrcSpan
l = do
    DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    (tw :: Bool
tw, pkgs :: Set InstalledUnitId
pkgs) <- Module -> SrcSpan -> Hsc (Bool, Set InstalledUnitId)
isModSafe Module
m SrcSpan
l
    case Bool
tw of
        False                     -> (Maybe InstalledUnitId, Set InstalledUnitId)
-> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe InstalledUnitId
forall a. Maybe a
Nothing, Set InstalledUnitId
pkgs)
        True | DynFlags -> Module -> Bool
isHomePkg DynFlags
dflags Module
m -> (Maybe InstalledUnitId, Set InstalledUnitId)
-> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe InstalledUnitId
forall a. Maybe a
Nothing, Set InstalledUnitId
pkgs)
             -- TODO: do we also have to check the trust of the instantiation?
             -- Not necessary if that is reflected in dependencies
             | Bool
otherwise   -> (Maybe InstalledUnitId, Set InstalledUnitId)
-> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return (InstalledUnitId -> Maybe InstalledUnitId
forall a. a -> Maybe a
Just (InstalledUnitId -> Maybe InstalledUnitId)
-> InstalledUnitId -> Maybe InstalledUnitId
forall a b. (a -> b) -> a -> b
$ UnitId -> InstalledUnitId
toInstalledUnitId (Module -> UnitId
moduleUnitId Module
m), Set InstalledUnitId
pkgs)
  where
    isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set InstalledUnitId)
    isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set InstalledUnitId)
isModSafe m :: Module
m l :: SrcSpan
l = do
        DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        Maybe ModIface
iface <- Module -> Hsc (Maybe ModIface)
lookup' Module
m
        case Maybe ModIface
iface of
            -- can't load iface to check trust!
            Nothing -> WarningMessages -> Hsc (Bool, Set InstalledUnitId)
forall (io :: * -> *) a. MonadIO io => WarningMessages -> io a
throwErrors (WarningMessages -> Hsc (Bool, Set InstalledUnitId))
-> WarningMessages -> Hsc (Bool, Set InstalledUnitId)
forall a b. (a -> b) -> a -> b
$ ErrMsg -> WarningMessages
forall a. a -> Bag a
unitBag (ErrMsg -> WarningMessages) -> ErrMsg -> WarningMessages
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg DynFlags
dflags SrcSpan
l
                         (SDoc -> ErrMsg) -> SDoc -> ErrMsg
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "Can't load the interface file for" SDoc -> SDoc -> SDoc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
m
                           SDoc -> SDoc -> SDoc
<> String -> SDoc
text ", to check that it can be safely imported"

            -- got iface, check trust
            Just iface' :: ModIface
iface' ->
                let trust :: SafeHaskellMode
trust = IfaceTrustInfo -> SafeHaskellMode
getSafeMode (IfaceTrustInfo -> SafeHaskellMode)
-> IfaceTrustInfo -> SafeHaskellMode
forall a b. (a -> b) -> a -> b
$ ModIface -> IfaceTrustInfo
mi_trust ModIface
iface'
                    trust_own_pkg :: Bool
trust_own_pkg = ModIface -> Bool
mi_trust_pkg ModIface
iface'
                    -- check module is trusted
                    safeM :: Bool
safeM = SafeHaskellMode
trust SafeHaskellMode -> [SafeHaskellMode] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [SafeHaskellMode
Sf_Safe, SafeHaskellMode
Sf_Trustworthy]
                    -- check package is trusted
                    safeP :: Bool
safeP = DynFlags -> SafeHaskellMode -> Bool -> Module -> Bool
packageTrusted DynFlags
dflags SafeHaskellMode
trust Bool
trust_own_pkg Module
m
                    -- pkg trust reqs
                    pkgRs :: Set InstalledUnitId
pkgRs = [InstalledUnitId] -> Set InstalledUnitId
forall a. Ord a => [a] -> Set a
S.fromList ([InstalledUnitId] -> Set InstalledUnitId)
-> ([(InstalledUnitId, Bool)] -> [InstalledUnitId])
-> [(InstalledUnitId, Bool)]
-> Set InstalledUnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((InstalledUnitId, Bool) -> InstalledUnitId)
-> [(InstalledUnitId, Bool)] -> [InstalledUnitId]
forall a b. (a -> b) -> [a] -> [b]
map (InstalledUnitId, Bool) -> InstalledUnitId
forall a b. (a, b) -> a
fst ([(InstalledUnitId, Bool)] -> Set InstalledUnitId)
-> [(InstalledUnitId, Bool)] -> Set InstalledUnitId
forall a b. (a -> b) -> a -> b
$ ((InstalledUnitId, Bool) -> Bool)
-> [(InstalledUnitId, Bool)] -> [(InstalledUnitId, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (InstalledUnitId, Bool) -> Bool
forall a b. (a, b) -> b
snd ([(InstalledUnitId, Bool)] -> [(InstalledUnitId, Bool)])
-> [(InstalledUnitId, Bool)] -> [(InstalledUnitId, Bool)]
forall a b. (a -> b) -> a -> b
$ Dependencies -> [(InstalledUnitId, Bool)]
dep_pkgs (Dependencies -> [(InstalledUnitId, Bool)])
-> Dependencies -> [(InstalledUnitId, Bool)]
forall a b. (a -> b) -> a -> b
$ ModIface -> Dependencies
mi_deps ModIface
iface'
                    -- General errors we throw but Safe errors we log
                    errs :: WarningMessages
errs = case (Bool
safeM, Bool
safeP) of
                        (True, True ) -> WarningMessages
forall a. Bag a
emptyBag
                        (True, False) -> WarningMessages
pkgTrustErr
                        (False, _   ) -> WarningMessages
modTrustErr
                in do
                    WarningMessages -> Hsc ()
logWarnings WarningMessages
errs
                    (Bool, Set InstalledUnitId) -> Hsc (Bool, Set InstalledUnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return (SafeHaskellMode
trust SafeHaskellMode -> SafeHaskellMode -> Bool
forall a. Eq a => a -> a -> Bool
== SafeHaskellMode
Sf_Trustworthy, Set InstalledUnitId
pkgRs)

                where
                    pkgTrustErr :: WarningMessages
pkgTrustErr = ErrMsg -> WarningMessages
forall a. a -> Bag a
unitBag (ErrMsg -> WarningMessages) -> ErrMsg -> WarningMessages
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> ErrMsg
mkErrMsg DynFlags
dflags SrcSpan
l (DynFlags -> PrintUnqualified
pkgQual DynFlags
dflags) (SDoc -> ErrMsg) -> SDoc -> ErrMsg
forall a b. (a -> b) -> a -> b
$
                        [SDoc] -> SDoc
sep [ ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> ModuleName
moduleName Module
m)
                                SDoc -> SDoc -> SDoc
<> String -> SDoc
text ": Can't be safely imported!"
                            , String -> SDoc
text "The package (" SDoc -> SDoc -> SDoc
<> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> UnitId
moduleUnitId Module
m)
                                SDoc -> SDoc -> SDoc
<> String -> SDoc
text ") the module resides in isn't trusted."
                            ]
                    modTrustErr :: WarningMessages
modTrustErr = ErrMsg -> WarningMessages
forall a. a -> Bag a
unitBag (ErrMsg -> WarningMessages) -> ErrMsg -> WarningMessages
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> ErrMsg
mkErrMsg DynFlags
dflags SrcSpan
l (DynFlags -> PrintUnqualified
pkgQual DynFlags
dflags) (SDoc -> ErrMsg) -> SDoc -> ErrMsg
forall a b. (a -> b) -> a -> b
$
                        [SDoc] -> SDoc
sep [ ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> ModuleName
moduleName Module
m)
                                SDoc -> SDoc -> SDoc
<> String -> SDoc
text ": Can't be safely imported!"
                            , String -> SDoc
text "The module itself isn't safe." ]

    -- | Check the package a module resides in is trusted. Safe compiled
    -- modules are trusted without requiring that their package is trusted. For
    -- trustworthy modules, modules in the home package are trusted but
    -- otherwise we check the package trust flag.
    packageTrusted :: DynFlags -> SafeHaskellMode -> Bool -> Module -> Bool
    packageTrusted :: DynFlags -> SafeHaskellMode -> Bool -> Module -> Bool
packageTrusted _ Sf_None      _ _ = Bool
False -- shouldn't hit these cases
    packageTrusted _ Sf_Ignore    _ _ = Bool
False -- shouldn't hit these cases
    packageTrusted _ Sf_Unsafe    _ _ = Bool
False -- prefer for completeness.
    packageTrusted dflags :: DynFlags
dflags _ _ _
        | Bool -> Bool
not (DynFlags -> Bool
packageTrustOn DynFlags
dflags) = Bool
True
    packageTrusted _ Sf_Safe  False _ = Bool
True
    packageTrusted dflags :: DynFlags
dflags _ _ m :: Module
m
        | DynFlags -> Module -> Bool
isHomePkg DynFlags
dflags Module
m = Bool
True
        | Bool
otherwise = InstalledPackageInfo
  ComponentId
  SourcePackageId
  PackageName
  InstalledUnitId
  UnitId
  ModuleName
  Module
-> Bool
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> Bool
trusted (InstalledPackageInfo
   ComponentId
   SourcePackageId
   PackageName
   InstalledUnitId
   UnitId
   ModuleName
   Module
 -> Bool)
-> InstalledPackageInfo
     ComponentId
     SourcePackageId
     PackageName
     InstalledUnitId
     UnitId
     ModuleName
     Module
-> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags
-> UnitId
-> InstalledPackageInfo
     ComponentId
     SourcePackageId
     PackageName
     InstalledUnitId
     UnitId
     ModuleName
     Module
getPackageDetails DynFlags
dflags (Module -> UnitId
moduleUnitId Module
m)

    lookup' :: Module -> Hsc (Maybe ModIface)
    lookup' :: Module -> Hsc (Maybe ModIface)
lookup' m :: Module
m = do
        DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
        ExternalPackageState
hsc_eps <- IO ExternalPackageState -> Hsc ExternalPackageState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExternalPackageState -> Hsc ExternalPackageState)
-> IO ExternalPackageState -> Hsc ExternalPackageState
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
        let pkgIfaceT :: PackageIfaceTable
pkgIfaceT = ExternalPackageState -> PackageIfaceTable
eps_PIT ExternalPackageState
hsc_eps
            homePkgT :: HomePackageTable
homePkgT  = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env
            iface :: Maybe ModIface
iface     = DynFlags
-> HomePackageTable
-> PackageIfaceTable
-> Module
-> Maybe ModIface
lookupIfaceByModule DynFlags
dflags HomePackageTable
homePkgT PackageIfaceTable
pkgIfaceT Module
m
        -- the 'lookupIfaceByModule' method will always fail when calling from GHCi
        -- as the compiler hasn't filled in the various module tables
        -- so we need to call 'getModuleInterface' to load from disk
        Maybe ModIface
iface' <- case Maybe ModIface
iface of
            Just _  -> Maybe ModIface -> Hsc (Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModIface
iface
            Nothing -> ((WarningMessages, WarningMessages), Maybe ModIface)
-> Maybe ModIface
forall a b. (a, b) -> b
snd (((WarningMessages, WarningMessages), Maybe ModIface)
 -> Maybe ModIface)
-> Hsc ((WarningMessages, WarningMessages), Maybe ModIface)
-> Hsc (Maybe ModIface)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (IO ((WarningMessages, WarningMessages), Maybe ModIface)
-> Hsc ((WarningMessages, WarningMessages), Maybe ModIface)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ((WarningMessages, WarningMessages), Maybe ModIface)
 -> Hsc ((WarningMessages, WarningMessages), Maybe ModIface))
-> IO ((WarningMessages, WarningMessages), Maybe ModIface)
-> Hsc ((WarningMessages, WarningMessages), Maybe ModIface)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Module
-> IO ((WarningMessages, WarningMessages), Maybe ModIface)
getModuleInterface HscEnv
hsc_env Module
m)
        Maybe ModIface -> Hsc (Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModIface
iface'


    isHomePkg :: DynFlags -> Module -> Bool
    isHomePkg :: DynFlags -> Module -> Bool
isHomePkg dflags :: DynFlags
dflags m :: Module
m
        | DynFlags -> UnitId
thisPackage DynFlags
dflags UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== Module -> UnitId
moduleUnitId Module
m = Bool
True
        | Bool
otherwise                               = Bool
False

-- | Check the list of packages are trusted.
checkPkgTrust :: Set InstalledUnitId -> Hsc ()
checkPkgTrust :: Set InstalledUnitId -> Hsc ()
checkPkgTrust pkgs :: Set InstalledUnitId
pkgs = do
    DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let errors :: [ErrMsg]
errors = (InstalledUnitId -> [ErrMsg] -> [ErrMsg])
-> [ErrMsg] -> Set InstalledUnitId -> [ErrMsg]
forall a b. (a -> b -> b) -> b -> Set a -> b
S.foldr InstalledUnitId -> [ErrMsg] -> [ErrMsg]
go [] Set InstalledUnitId
pkgs
        go :: InstalledUnitId -> [ErrMsg] -> [ErrMsg]
go pkg :: InstalledUnitId
pkg acc :: [ErrMsg]
acc
            | InstalledPackageInfo
  ComponentId
  SourcePackageId
  PackageName
  InstalledUnitId
  UnitId
  ModuleName
  Module
-> Bool
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> Bool
trusted (InstalledPackageInfo
   ComponentId
   SourcePackageId
   PackageName
   InstalledUnitId
   UnitId
   ModuleName
   Module
 -> Bool)
-> InstalledPackageInfo
     ComponentId
     SourcePackageId
     PackageName
     InstalledUnitId
     UnitId
     ModuleName
     Module
-> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags
-> InstalledUnitId
-> InstalledPackageInfo
     ComponentId
     SourcePackageId
     PackageName
     InstalledUnitId
     UnitId
     ModuleName
     Module
getInstalledPackageDetails DynFlags
dflags InstalledUnitId
pkg
            = [ErrMsg]
acc
            | Bool
otherwise
            = (ErrMsg -> [ErrMsg] -> [ErrMsg]
forall a. a -> [a] -> [a]
:[ErrMsg]
acc) (ErrMsg -> [ErrMsg]) -> ErrMsg -> [ErrMsg]
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> ErrMsg
mkErrMsg DynFlags
dflags SrcSpan
noSrcSpan (DynFlags -> PrintUnqualified
pkgQual DynFlags
dflags)
                     (SDoc -> ErrMsg) -> SDoc -> ErrMsg
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "The package (" SDoc -> SDoc -> SDoc
<> InstalledUnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstalledUnitId
pkg SDoc -> SDoc -> SDoc
<> String -> SDoc
text ") is required" SDoc -> SDoc -> SDoc
<>
                       String -> SDoc
text " to be trusted but it isn't!"
    case [ErrMsg]
errors of
        [] -> () -> Hsc ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        _  -> (IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> ([ErrMsg] -> IO ()) -> [ErrMsg] -> Hsc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (SourceError -> IO ())
-> ([ErrMsg] -> SourceError) -> [ErrMsg] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WarningMessages -> SourceError
mkSrcErr (WarningMessages -> SourceError)
-> ([ErrMsg] -> WarningMessages) -> [ErrMsg] -> SourceError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ErrMsg] -> WarningMessages
forall a. [a] -> Bag a
listToBag) [ErrMsg]
errors

-- | Set module to unsafe and (potentially) wipe trust information.
--
-- Make sure to call this method to set a module to inferred unsafe, it should
-- be a central and single failure method. We only wipe the trust information
-- when we aren't in a specific Safe Haskell mode.
--
-- While we only use this for recording that a module was inferred unsafe, we
-- may call it on modules using Trustworthy or Unsafe flags so as to allow
-- warning flags for safety to function correctly. See Note [Safe Haskell
-- Inference].
markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
markUnsafeInfer tcg_env :: TcGblEnv
tcg_env whyUnsafe :: WarningMessages
whyUnsafe = do
    DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

    Bool -> Hsc () -> Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnUnsafe DynFlags
dflags)
         (WarningMessages -> Hsc ()
logWarnings (WarningMessages -> Hsc ()) -> WarningMessages -> Hsc ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> WarningMessages
forall a. a -> Bag a
unitBag (ErrMsg -> WarningMessages) -> ErrMsg -> WarningMessages
forall a b. (a -> b) -> a -> b
$ WarnReason -> ErrMsg -> ErrMsg
makeIntoWarning (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnUnsafe) (ErrMsg -> ErrMsg) -> ErrMsg -> ErrMsg
forall a b. (a -> b) -> a -> b
$
             DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainWarnMsg DynFlags
dflags (DynFlags -> SrcSpan
warnUnsafeOnLoc DynFlags
dflags) (DynFlags -> SDoc
whyUnsafe' DynFlags
dflags))

    IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ IORef (Bool, WarningMessages) -> (Bool, WarningMessages) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (TcGblEnv -> IORef (Bool, WarningMessages)
tcg_safeInfer TcGblEnv
tcg_env) (Bool
False, WarningMessages
whyUnsafe)
    -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other
    -- times inference may be on but we are in Trustworthy mode -- so we want
    -- to record safe-inference failed but not wipe the trust dependencies.
    case Bool -> Bool
not (DynFlags -> Bool
safeHaskellModeEnabled DynFlags
dflags) of
      True  -> TcGblEnv -> Hsc TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> Hsc TcGblEnv) -> TcGblEnv -> Hsc TcGblEnv
forall a b. (a -> b) -> a -> b
$ TcGblEnv
tcg_env { tcg_imports :: ImportAvails
tcg_imports = ImportAvails
wiped_trust }
      False -> TcGblEnv -> Hsc TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env

  where
    wiped_trust :: ImportAvails
wiped_trust   = (TcGblEnv -> ImportAvails
tcg_imports TcGblEnv
tcg_env) { imp_trust_pkgs :: Set InstalledUnitId
imp_trust_pkgs = Set InstalledUnitId
forall a. Set a
S.empty }
    pprMod :: SDoc
pprMod        = ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModuleName -> SDoc) -> ModuleName -> SDoc
forall a b. (a -> b) -> a -> b
$ Module -> ModuleName
moduleName (Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env
    whyUnsafe' :: DynFlags -> SDoc
whyUnsafe' df :: DynFlags
df = [SDoc] -> SDoc
vcat [ SDoc -> SDoc
quotes SDoc
pprMod SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "has been inferred as unsafe!"
                         , String -> SDoc
text "Reason:"
                         , Int -> SDoc -> SDoc
nest 4 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ DynFlags -> [SDoc]
badFlags DynFlags
df) SDoc -> SDoc -> SDoc
$+$
                                    ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ WarningMessages -> [SDoc]
pprErrMsgBagWithLoc WarningMessages
whyUnsafe) SDoc -> SDoc -> SDoc
$+$
                                    ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ [ClsInst] -> [SDoc]
badInsts ([ClsInst] -> [SDoc]) -> [ClsInst] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ TcGblEnv -> [ClsInst]
tcg_insts TcGblEnv
tcg_env)
                         ]
    badFlags :: DynFlags -> [SDoc]
badFlags df :: DynFlags
df   = [[SDoc]] -> [SDoc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[SDoc]] -> [SDoc]) -> [[SDoc]] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ ((String, DynFlags -> SrcSpan, DynFlags -> Bool,
  DynFlags -> DynFlags)
 -> [SDoc])
-> [(String, DynFlags -> SrcSpan, DynFlags -> Bool,
     DynFlags -> DynFlags)]
-> [[SDoc]]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags
-> (String, DynFlags -> SrcSpan, DynFlags -> Bool,
    DynFlags -> DynFlags)
-> [SDoc]
forall t d. t -> (String, t -> SrcSpan, t -> Bool, d) -> [SDoc]
badFlag DynFlags
df) [(String, DynFlags -> SrcSpan, DynFlags -> Bool,
  DynFlags -> DynFlags)]
unsafeFlagsForInfer
    badFlag :: t -> (String, t -> SrcSpan, t -> Bool, d) -> [SDoc]
badFlag df :: t
df (str :: String
str,loc :: t -> SrcSpan
loc,on :: t -> Bool
on,_)
        | t -> Bool
on t
df     = [Severity -> SrcSpan -> SDoc -> SDoc
mkLocMessage Severity
SevOutput (t -> SrcSpan
loc t
df) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                            String -> SDoc
text String
str SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is not allowed in Safe Haskell"]
        | Bool
otherwise = []
    badInsts :: [ClsInst] -> [SDoc]
badInsts insts :: [ClsInst]
insts = [[SDoc]] -> [SDoc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[SDoc]] -> [SDoc]) -> [[SDoc]] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ (ClsInst -> [SDoc]) -> [ClsInst] -> [[SDoc]]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> [SDoc]
badInst [ClsInst]
insts

    checkOverlap :: OverlapMode -> Bool
checkOverlap (NoOverlap _) = Bool
False
    checkOverlap _             = Bool
True

    badInst :: ClsInst -> [SDoc]
badInst ins :: ClsInst
ins | OverlapMode -> Bool
checkOverlap (OverlapFlag -> OverlapMode
overlapMode (ClsInst -> OverlapFlag
is_flag ClsInst
ins))
                = [Severity -> SrcSpan -> SDoc -> SDoc
mkLocMessage Severity
SevOutput (Name -> SrcSpan
nameSrcSpan (Name -> SrcSpan) -> Name -> SrcSpan
forall a b. (a -> b) -> a -> b
$ DFunId -> Name
forall a. NamedThing a => a -> Name
getName (DFunId -> Name) -> DFunId -> Name
forall a b. (a -> b) -> a -> b
$ ClsInst -> DFunId
is_dfun ClsInst
ins) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                      OverlapMode -> SDoc
forall a. Outputable a => a -> SDoc
ppr (OverlapFlag -> OverlapMode
overlapMode (OverlapFlag -> OverlapMode) -> OverlapFlag -> OverlapMode
forall a b. (a -> b) -> a -> b
$ ClsInst -> OverlapFlag
is_flag ClsInst
ins) SDoc -> SDoc -> SDoc
<+>
                      String -> SDoc
text "overlap mode isn't allowed in Safe Haskell"]
                | Bool
otherwise = []


-- | Figure out the final correct safe haskell mode
hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode
hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode
hscGetSafeMode tcg_env :: TcGblEnv
tcg_env = do
    DynFlags
dflags  <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    IO SafeHaskellMode -> Hsc SafeHaskellMode
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SafeHaskellMode -> Hsc SafeHaskellMode)
-> IO SafeHaskellMode -> Hsc SafeHaskellMode
forall a b. (a -> b) -> a -> b
$ DynFlags -> TcGblEnv -> IO SafeHaskellMode
finalSafeMode DynFlags
dflags TcGblEnv
tcg_env

--------------------------------------------------------------
-- Simplifiers
--------------------------------------------------------------

hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts
hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts
hscSimplify hsc_env :: HscEnv
hsc_env plugins :: [String]
plugins modguts :: ModGuts
modguts =
    HscEnv -> Hsc ModGuts -> IO ModGuts
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc ModGuts -> IO ModGuts) -> Hsc ModGuts -> IO ModGuts
forall a b. (a -> b) -> a -> b
$ [String] -> ModGuts -> Hsc ModGuts
hscSimplify' [String]
plugins ModGuts
modguts

hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts
hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts
hscSimplify' plugins :: [String]
plugins ds_result :: ModGuts
ds_result = do
    HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
    let hsc_env_with_plugins :: HscEnv
hsc_env_with_plugins = HscEnv
hsc_env
          { hsc_dflags :: DynFlags
hsc_dflags = (String -> DynFlags -> DynFlags)
-> DynFlags -> [String] -> DynFlags
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> DynFlags -> DynFlags
addPluginModuleName (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) [String]
plugins
          }
    {-# SCC "Core2Core" #-}
      IO ModGuts -> Hsc ModGuts
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModGuts -> Hsc ModGuts) -> IO ModGuts -> Hsc ModGuts
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModGuts -> IO ModGuts
core2core HscEnv
hsc_env_with_plugins ModGuts
ds_result

--------------------------------------------------------------
-- Interface generators
--------------------------------------------------------------

hscSimpleIface :: HscEnv
               -> TcGblEnv
               -> Maybe Fingerprint
               -> IO (ModIface, Bool, ModDetails)
hscSimpleIface :: HscEnv
-> TcGblEnv -> Maybe Fingerprint -> IO (ModIface, Bool, ModDetails)
hscSimpleIface hsc_env :: HscEnv
hsc_env tc_result :: TcGblEnv
tc_result mb_old_iface :: Maybe Fingerprint
mb_old_iface
    = HscEnv
-> Hsc (ModIface, Bool, ModDetails)
-> IO (ModIface, Bool, ModDetails)
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc (ModIface, Bool, ModDetails)
 -> IO (ModIface, Bool, ModDetails))
-> Hsc (ModIface, Bool, ModDetails)
-> IO (ModIface, Bool, ModDetails)
forall a b. (a -> b) -> a -> b
$ TcGblEnv -> Maybe Fingerprint -> Hsc (ModIface, Bool, ModDetails)
hscSimpleIface' TcGblEnv
tc_result Maybe Fingerprint
mb_old_iface

hscSimpleIface' :: TcGblEnv
                -> Maybe Fingerprint
                -> Hsc (ModIface, Bool, ModDetails)
hscSimpleIface' :: TcGblEnv -> Maybe Fingerprint -> Hsc (ModIface, Bool, ModDetails)
hscSimpleIface' tc_result :: TcGblEnv
tc_result mb_old_iface :: Maybe Fingerprint
mb_old_iface = do
    HscEnv
hsc_env   <- Hsc HscEnv
getHscEnv
    ModDetails
details   <- IO ModDetails -> Hsc ModDetails
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModDetails -> Hsc ModDetails)
-> IO ModDetails -> Hsc ModDetails
forall a b. (a -> b) -> a -> b
$ HscEnv -> TcGblEnv -> IO ModDetails
mkBootModDetailsTc HscEnv
hsc_env TcGblEnv
tc_result
    SafeHaskellMode
safe_mode <- TcGblEnv -> Hsc SafeHaskellMode
hscGetSafeMode TcGblEnv
tc_result
    (new_iface :: ModIface
new_iface, no_change :: Bool
no_change)
        <- {-# SCC "MkFinalIface" #-}
           IO (ModIface, Bool) -> Hsc (ModIface, Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ModIface, Bool) -> Hsc (ModIface, Bool))
-> IO (ModIface, Bool) -> Hsc (ModIface, Bool)
forall a b. (a -> b) -> a -> b
$
               HscEnv
-> Maybe Fingerprint
-> SafeHaskellMode
-> ModDetails
-> TcGblEnv
-> IO (ModIface, Bool)
mkIfaceTc HscEnv
hsc_env Maybe Fingerprint
mb_old_iface SafeHaskellMode
safe_mode ModDetails
details TcGblEnv
tc_result
    -- And the answer is ...
    IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ()
dumpIfaceStats HscEnv
hsc_env
    (ModIface, Bool, ModDetails) -> Hsc (ModIface, Bool, ModDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface
new_iface, Bool
no_change, ModDetails
details)

hscNormalIface :: HscEnv
               -> ModGuts
               -> Maybe Fingerprint
               -> IO (ModIface, Bool, ModDetails, CgGuts)
hscNormalIface :: HscEnv
-> ModGuts
-> Maybe Fingerprint
-> IO (ModIface, Bool, ModDetails, CgGuts)
hscNormalIface hsc_env :: HscEnv
hsc_env simpl_result :: ModGuts
simpl_result mb_old_iface :: Maybe Fingerprint
mb_old_iface =
    HscEnv
-> Hsc (ModIface, Bool, ModDetails, CgGuts)
-> IO (ModIface, Bool, ModDetails, CgGuts)
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc (ModIface, Bool, ModDetails, CgGuts)
 -> IO (ModIface, Bool, ModDetails, CgGuts))
-> Hsc (ModIface, Bool, ModDetails, CgGuts)
-> IO (ModIface, Bool, ModDetails, CgGuts)
forall a b. (a -> b) -> a -> b
$ ModGuts
-> Maybe Fingerprint -> Hsc (ModIface, Bool, ModDetails, CgGuts)
hscNormalIface' ModGuts
simpl_result Maybe Fingerprint
mb_old_iface

hscNormalIface' :: ModGuts
                -> Maybe Fingerprint
                -> Hsc (ModIface, Bool, ModDetails, CgGuts)
hscNormalIface' :: ModGuts
-> Maybe Fingerprint -> Hsc (ModIface, Bool, ModDetails, CgGuts)
hscNormalIface' simpl_result :: ModGuts
simpl_result mb_old_iface :: Maybe Fingerprint
mb_old_iface = do
    HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
    (cg_guts :: CgGuts
cg_guts, details :: ModDetails
details) <- {-# SCC "CoreTidy" #-}
                          IO (CgGuts, ModDetails) -> Hsc (CgGuts, ModDetails)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (CgGuts, ModDetails) -> Hsc (CgGuts, ModDetails))
-> IO (CgGuts, ModDetails) -> Hsc (CgGuts, ModDetails)
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
tidyProgram HscEnv
hsc_env ModGuts
simpl_result

    -- BUILD THE NEW ModIface and ModDetails
    --  and emit external core if necessary
    -- This has to happen *after* code gen so that the back-end
    -- info has been set. Not yet clear if it matters waiting
    -- until after code output
    (new_iface :: ModIface
new_iface, no_change :: Bool
no_change)
        <- {-# SCC "MkFinalIface" #-}
           IO (ModIface, Bool) -> Hsc (ModIface, Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ModIface, Bool) -> Hsc (ModIface, Bool))
-> IO (ModIface, Bool) -> Hsc (ModIface, Bool)
forall a b. (a -> b) -> a -> b
$
               HscEnv
-> Maybe Fingerprint
-> ModDetails
-> ModGuts
-> IO (ModIface, Bool)
mkIface HscEnv
hsc_env Maybe Fingerprint
mb_old_iface ModDetails
details ModGuts
simpl_result

    IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ()
dumpIfaceStats HscEnv
hsc_env

    -- Return the prepared code.
    (ModIface, Bool, ModDetails, CgGuts)
-> Hsc (ModIface, Bool, ModDetails, CgGuts)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface
new_iface, Bool
no_change, ModDetails
details, CgGuts
cg_guts)

--------------------------------------------------------------
-- BackEnd combinators
--------------------------------------------------------------

hscWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
hscWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
hscWriteIface dflags :: DynFlags
dflags iface :: ModIface
iface no_change :: Bool
no_change mod_summary :: ModSummary
mod_summary = do
    let ifaceFile :: String
ifaceFile = ModLocation -> String
ml_hi_file (ModSummary -> ModLocation
ms_location ModSummary
mod_summary)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
no_change (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        {-# SCC "writeIface" #-}
        DynFlags -> String -> ModIface -> IO ()
writeIfaceFile DynFlags
dflags String
ifaceFile ModIface
iface
    DynFlags -> IO () -> IO ()
forall (m :: * -> *). MonadIO m => DynFlags -> m () -> m ()
whenGeneratingDynamicToo DynFlags
dflags (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        -- TODO: We should do a no_change check for the dynamic
        --       interface file too
        -- TODO: Should handle the dynamic hi filename properly
        let dynIfaceFile :: String
dynIfaceFile = String -> String -> String
replaceExtension String
ifaceFile (DynFlags -> String
dynHiSuf DynFlags
dflags)
            dynIfaceFile' :: String
dynIfaceFile' = Bool -> String -> String
addBootSuffix_maybe (ModIface -> Bool
mi_boot ModIface
iface) String
dynIfaceFile
            dynDflags :: DynFlags
dynDflags = DynFlags -> DynFlags
dynamicTooMkDynamicDynFlags DynFlags
dflags
        DynFlags -> String -> ModIface -> IO ()
writeIfaceFile DynFlags
dynDflags String
dynIfaceFile' ModIface
iface

-- | Compile to hard-code.
hscGenHardCode :: HscEnv -> CgGuts -> ModSummary -> FilePath
               -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)])
               -- ^ @Just f@ <=> _stub.c is f
hscGenHardCode :: HscEnv
-> CgGuts
-> ModSummary
-> String
-> IO (String, Maybe String, [(ForeignSrcLang, String)])
hscGenHardCode hsc_env :: HscEnv
hsc_env cgguts :: CgGuts
cgguts mod_summary :: ModSummary
mod_summary output_filename :: String
output_filename = do
        let CgGuts{ -- This is the last use of the ModGuts in a compilation.
                    -- From now on, we just use the bits we need.
                    cg_module :: CgGuts -> Module
cg_module   = Module
this_mod,
                    cg_binds :: CgGuts -> CoreProgram
cg_binds    = CoreProgram
core_binds,
                    cg_tycons :: CgGuts -> [TyCon]
cg_tycons   = [TyCon]
tycons,
                    cg_foreign :: CgGuts -> ForeignStubs
cg_foreign  = ForeignStubs
foreign_stubs0,
                    cg_foreign_files :: CgGuts -> [(ForeignSrcLang, String)]
cg_foreign_files = [(ForeignSrcLang, String)]
foreign_files,
                    cg_dep_pkgs :: CgGuts -> [InstalledUnitId]
cg_dep_pkgs = [InstalledUnitId]
dependencies,
                    cg_hpc_info :: CgGuts -> HpcInfo
cg_hpc_info = HpcInfo
hpc_info } = CgGuts
cgguts
            dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
            location :: ModLocation
location = ModSummary -> ModLocation
ms_location ModSummary
mod_summary
            data_tycons :: [TyCon]
data_tycons = (TyCon -> Bool) -> [TyCon] -> [TyCon]
forall a. (a -> Bool) -> [a] -> [a]
filter TyCon -> Bool
isDataTyCon [TyCon]
tycons
            -- cg_tycons includes newtypes, for the benefit of External Core,
            -- but we don't generate any code for newtypes

        -------------------
        -- PREPARE FOR CODE GENERATION
        -- Do saturation and convert to A-normal form
        (prepd_binds :: CoreProgram
prepd_binds, local_ccs :: Set CostCentre
local_ccs) <- {-# SCC "CorePrep" #-}
                       HscEnv
-> Module
-> ModLocation
-> CoreProgram
-> [TyCon]
-> IO (CoreProgram, Set CostCentre)
corePrepPgm HscEnv
hsc_env Module
this_mod ModLocation
location
                                   CoreProgram
core_binds [TyCon]
data_tycons
        -----------------  Convert to STG ------------------
        (stg_binds :: [StgTopBinding]
stg_binds, (caf_ccs :: [CostCentre]
caf_ccs, caf_cc_stacks :: [CostCentreStack]
caf_cc_stacks))
            <- {-# SCC "CoreToStg" #-}
               DynFlags
-> Module -> CoreProgram -> IO ([StgTopBinding], CollectedCCs)
myCoreToStg DynFlags
dflags Module
this_mod CoreProgram
prepd_binds

        let cost_centre_info :: CollectedCCs
cost_centre_info =
              (Set CostCentre -> [CostCentre]
forall a. Set a -> [a]
S.toList Set CostCentre
local_ccs [CostCentre] -> [CostCentre] -> [CostCentre]
forall a. [a] -> [a] -> [a]
++ [CostCentre]
caf_ccs, [CostCentreStack]
caf_cc_stacks)
            prof_init :: SDoc
prof_init = Module -> CollectedCCs -> SDoc
profilingInitCode Module
this_mod CollectedCCs
cost_centre_info
            foreign_stubs :: ForeignStubs
foreign_stubs = ForeignStubs
foreign_stubs0 ForeignStubs -> SDoc -> ForeignStubs
`appendStubC` SDoc
prof_init

        ------------------  Code generation ------------------

        -- The back-end is streamed: each top-level function goes
        -- from Stg all the way to asm before dealing with the next
        -- top-level function, so showPass isn't very useful here.
        -- Hence we have one showPass for the whole backend, the
        -- next showPass after this will be "Assembler".
        IO DynFlags
-> SDoc
-> ((String, Maybe String, [(ForeignSrcLang, String)]) -> ())
-> IO (String, Maybe String, [(ForeignSrcLang, String)])
-> IO (String, Maybe String, [(ForeignSrcLang, String)])
forall (m :: * -> *) a.
MonadIO m =>
m DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming (DynFlags -> IO DynFlags
forall (f :: * -> *) a. Applicative f => a -> f a
pure DynFlags
dflags)
                   (String -> SDoc
text "CodeGen"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
                   (() -> (String, Maybe String, [(ForeignSrcLang, String)]) -> ()
forall a b. a -> b -> a
const ()) (IO (String, Maybe String, [(ForeignSrcLang, String)])
 -> IO (String, Maybe String, [(ForeignSrcLang, String)]))
-> IO (String, Maybe String, [(ForeignSrcLang, String)])
-> IO (String, Maybe String, [(ForeignSrcLang, String)])
forall a b. (a -> b) -> a -> b
$ do
            Stream IO CmmGroup ()
cmms <- {-# SCC "StgCmm" #-}
                            HscEnv
-> Module
-> [TyCon]
-> CollectedCCs
-> [StgTopBinding]
-> HpcInfo
-> IO (Stream IO CmmGroup ())
doCodeGen HscEnv
hsc_env Module
this_mod [TyCon]
data_tycons
                                CollectedCCs
cost_centre_info
                                [StgTopBinding]
stg_binds HpcInfo
hpc_info

            ------------------  Code output -----------------------
            Stream IO RawCmmGroup ()
rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
                      DynFlags -> Stream IO CmmGroup () -> IO (Stream IO RawCmmGroup ())
cmmToRawCmm DynFlags
dflags Stream IO CmmGroup ()
cmms

            let dump :: b -> IO b
dump a :: b
a = do DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_cmm_raw "Raw Cmm"
                              (b -> SDoc
forall a. Outputable a => a -> SDoc
ppr b
a)
                            b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
a
                rawcmms1 :: Stream IO RawCmmGroup ()
rawcmms1 = (RawCmmGroup -> IO RawCmmGroup)
-> Stream IO RawCmmGroup () -> Stream IO RawCmmGroup ()
forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> Stream m a x -> Stream m b x
Stream.mapM RawCmmGroup -> IO RawCmmGroup
forall b. Outputable b => b -> IO b
dump Stream IO RawCmmGroup ()
rawcmms0

            (output_filename :: String
output_filename, (_stub_h_exists :: Bool
_stub_h_exists, stub_c_exists :: Maybe String
stub_c_exists), foreign_fps :: [(ForeignSrcLang, String)]
foreign_fps)
                <- {-# SCC "codeOutput" #-}
                  DynFlags
-> Module
-> String
-> ModLocation
-> ForeignStubs
-> [(ForeignSrcLang, String)]
-> [InstalledUnitId]
-> Stream IO RawCmmGroup ()
-> IO (String, (Bool, Maybe String), [(ForeignSrcLang, String)])
codeOutput DynFlags
dflags Module
this_mod String
output_filename ModLocation
location
                  ForeignStubs
foreign_stubs [(ForeignSrcLang, String)]
foreign_files [InstalledUnitId]
dependencies Stream IO RawCmmGroup ()
rawcmms1
            (String, Maybe String, [(ForeignSrcLang, String)])
-> IO (String, Maybe String, [(ForeignSrcLang, String)])
forall (m :: * -> *) a. Monad m => a -> m a
return (String
output_filename, Maybe String
stub_c_exists, [(ForeignSrcLang, String)]
foreign_fps)


hscInteractive :: HscEnv
               -> CgGuts
               -> ModSummary
               -> IO (Maybe FilePath, CompiledByteCode, [SptEntry])
hscInteractive :: HscEnv
-> CgGuts
-> ModSummary
-> IO (Maybe String, CompiledByteCode, [SptEntry])
hscInteractive hsc_env :: HscEnv
hsc_env cgguts :: CgGuts
cgguts mod_summary :: ModSummary
mod_summary = do
    let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    let CgGuts{ -- This is the last use of the ModGuts in a compilation.
                -- From now on, we just use the bits we need.
               cg_module :: CgGuts -> Module
cg_module   = Module
this_mod,
               cg_binds :: CgGuts -> CoreProgram
cg_binds    = CoreProgram
core_binds,
               cg_tycons :: CgGuts -> [TyCon]
cg_tycons   = [TyCon]
tycons,
               cg_foreign :: CgGuts -> ForeignStubs
cg_foreign  = ForeignStubs
foreign_stubs,
               cg_modBreaks :: CgGuts -> Maybe ModBreaks
cg_modBreaks = Maybe ModBreaks
mod_breaks,
               cg_spt_entries :: CgGuts -> [SptEntry]
cg_spt_entries = [SptEntry]
spt_entries } = CgGuts
cgguts

        location :: ModLocation
location = ModSummary -> ModLocation
ms_location ModSummary
mod_summary
        data_tycons :: [TyCon]
data_tycons = (TyCon -> Bool) -> [TyCon] -> [TyCon]
forall a. (a -> Bool) -> [a] -> [a]
filter TyCon -> Bool
isDataTyCon [TyCon]
tycons
        -- cg_tycons includes newtypes, for the benefit of External Core,
        -- but we don't generate any code for newtypes

    -------------------
    -- PREPARE FOR CODE GENERATION
    -- Do saturation and convert to A-normal form
    (prepd_binds :: CoreProgram
prepd_binds, _) <- {-# SCC "CorePrep" #-}
                   HscEnv
-> Module
-> ModLocation
-> CoreProgram
-> [TyCon]
-> IO (CoreProgram, Set CostCentre)
corePrepPgm HscEnv
hsc_env Module
this_mod ModLocation
location CoreProgram
core_binds [TyCon]
data_tycons
    -----------------  Generate byte code ------------------
    CompiledByteCode
comp_bc <- HscEnv
-> Module
-> CoreProgram
-> [TyCon]
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen HscEnv
hsc_env Module
this_mod CoreProgram
prepd_binds [TyCon]
data_tycons Maybe ModBreaks
mod_breaks
    ------------------ Create f-x-dynamic C-side stuff -----
    (_istub_h_exists :: Bool
_istub_h_exists, istub_c_exists :: Maybe String
istub_c_exists)
        <- DynFlags
-> Module -> ModLocation -> ForeignStubs -> IO (Bool, Maybe String)
outputForeignStubs DynFlags
dflags Module
this_mod ModLocation
location ForeignStubs
foreign_stubs
    (Maybe String, CompiledByteCode, [SptEntry])
-> IO (Maybe String, CompiledByteCode, [SptEntry])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String
istub_c_exists, CompiledByteCode
comp_bc, [SptEntry]
spt_entries)

------------------------------

hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO ()
hscCompileCmmFile :: HscEnv -> String -> String -> IO ()
hscCompileCmmFile hsc_env :: HscEnv
hsc_env filename :: String
filename output_filename :: String
output_filename = HscEnv -> Hsc () -> IO ()
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc () -> IO ()) -> Hsc () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    CmmGroup
cmm <- IO ((WarningMessages, WarningMessages), Maybe CmmGroup)
-> Hsc CmmGroup
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO ((WarningMessages, WarningMessages), Maybe CmmGroup)
 -> Hsc CmmGroup)
-> IO ((WarningMessages, WarningMessages), Maybe CmmGroup)
-> Hsc CmmGroup
forall a b. (a -> b) -> a -> b
$ DynFlags
-> String
-> IO ((WarningMessages, WarningMessages), Maybe CmmGroup)
parseCmmFile DynFlags
dflags String
filename
    IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ do
        DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_cmm_verbose "Parsed Cmm" (CmmGroup -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmGroup
cmm)
        let -- Make up a module name to give the NCG. We can't pass bottom here
            -- lest we reproduce #11784.
            mod_name :: ModuleName
mod_name = String -> ModuleName
mkModuleName (String -> ModuleName) -> String -> ModuleName
forall a b. (a -> b) -> a -> b
$ "Cmm$" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
FilePath.takeFileName String
filename
            cmm_mod :: Module
cmm_mod = UnitId -> ModuleName -> Module
mkModule (DynFlags -> UnitId
thisPackage DynFlags
dflags) ModuleName
mod_name
        (_, cmmgroup :: CmmGroup
cmmgroup) <- HscEnv -> ModuleSRTInfo -> CmmGroup -> IO (ModuleSRTInfo, CmmGroup)
cmmPipeline HscEnv
hsc_env (Module -> ModuleSRTInfo
emptySRT Module
cmm_mod) CmmGroup
cmm
        DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_cmm "Output Cmm" (CmmGroup -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmGroup
cmmgroup)
        Stream IO RawCmmGroup ()
rawCmms <- DynFlags -> Stream IO CmmGroup () -> IO (Stream IO RawCmmGroup ())
cmmToRawCmm DynFlags
dflags (CmmGroup -> Stream IO CmmGroup ()
forall (m :: * -> *) a. Monad m => a -> Stream m a ()
Stream.yield CmmGroup
cmmgroup)
        (String, (Bool, Maybe String), [(ForeignSrcLang, String)])
_ <- DynFlags
-> Module
-> String
-> ModLocation
-> ForeignStubs
-> [(ForeignSrcLang, String)]
-> [InstalledUnitId]
-> Stream IO RawCmmGroup ()
-> IO (String, (Bool, Maybe String), [(ForeignSrcLang, String)])
codeOutput DynFlags
dflags Module
cmm_mod String
output_filename ModLocation
no_loc ForeignStubs
NoStubs [] []
             Stream IO RawCmmGroup ()
rawCmms
        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    no_loc :: ModLocation
no_loc = ModLocation :: Maybe String -> String -> String -> String -> ModLocation
ModLocation{ ml_hs_file :: Maybe String
ml_hs_file  = String -> Maybe String
forall a. a -> Maybe a
Just String
filename,
                          ml_hi_file :: String
ml_hi_file  = String -> String
forall a. String -> a
panic "hscCompileCmmFile: no hi file",
                          ml_obj_file :: String
ml_obj_file = String -> String
forall a. String -> a
panic "hscCompileCmmFile: no obj file",
                          ml_hie_file :: String
ml_hie_file = String -> String
forall a. String -> a
panic "hscCompileCmmFile: no hie file"}

-------------------- Stuff for new code gen ---------------------

doCodeGen   :: HscEnv -> Module -> [TyCon]
            -> CollectedCCs
            -> [StgTopBinding]
            -> HpcInfo
            -> IO (Stream IO CmmGroup ())
         -- Note we produce a 'Stream' of CmmGroups, so that the
         -- backend can be run incrementally.  Otherwise it generates all
         -- the C-- up front, which has a significant space cost.
doCodeGen :: HscEnv
-> Module
-> [TyCon]
-> CollectedCCs
-> [StgTopBinding]
-> HpcInfo
-> IO (Stream IO CmmGroup ())
doCodeGen hsc_env :: HscEnv
hsc_env this_mod :: Module
this_mod data_tycons :: [TyCon]
data_tycons
              cost_centre_info :: CollectedCCs
cost_centre_info stg_binds :: [StgTopBinding]
stg_binds hpc_info :: HpcInfo
hpc_info = do
    let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

    let stg_binds_w_fvs :: [CgStgTopBinding]
stg_binds_w_fvs = [StgTopBinding] -> [CgStgTopBinding]
annTopBindingsFreeVars [StgTopBinding]
stg_binds
    let cmm_stream :: Stream IO CmmGroup ()
        cmm_stream :: Stream IO CmmGroup ()
cmm_stream = {-# SCC "StgCmm" #-}
            DynFlags
-> Module
-> [TyCon]
-> CollectedCCs
-> [CgStgTopBinding]
-> HpcInfo
-> Stream IO CmmGroup ()
StgCmm.codeGen DynFlags
dflags Module
this_mod [TyCon]
data_tycons
                           CollectedCCs
cost_centre_info [CgStgTopBinding]
stg_binds_w_fvs HpcInfo
hpc_info

        -- codegen consumes a stream of CmmGroup, and produces a new
        -- stream of CmmGroup (not necessarily synchronised: one
        -- CmmGroup on input may produce many CmmGroups on output due
        -- to proc-point splitting).

    let dump1 :: b -> IO b
dump1 a :: b
a = do DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_cmm_from_stg
                       "Cmm produced by codegen" (b -> SDoc
forall a. Outputable a => a -> SDoc
ppr b
a)
                     b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
a

        ppr_stream1 :: Stream IO CmmGroup ()
ppr_stream1 = (CmmGroup -> IO CmmGroup)
-> Stream IO CmmGroup () -> Stream IO CmmGroup ()
forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> Stream m a x -> Stream m b x
Stream.mapM CmmGroup -> IO CmmGroup
forall b. Outputable b => b -> IO b
dump1 Stream IO CmmGroup ()
cmm_stream

    -- We are building a single SRT for the entire module, so
    -- we must thread it through all the procedures as we cps-convert them.
    UniqSupply
us <- Char -> IO UniqSupply
mkSplitUniqSupply 'S'

    -- When splitting, we generate one SRT per split chunk, otherwise
    -- we generate one SRT for the whole module.
    let
     pipeline_stream :: Stream IO CmmGroup ()
pipeline_stream
      | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SplitObjs DynFlags
dflags Bool -> Bool -> Bool
|| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SplitSections DynFlags
dflags Bool -> Bool -> Bool
||
        OS -> Bool
osSubsectionsViaSymbols (Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags))
        = {-# SCC "cmmPipeline" #-}
          let run_pipeline :: a -> CmmGroup -> IO (a, CmmGroup)
run_pipeline us :: a
us cmmgroup :: CmmGroup
cmmgroup = do
                (_topSRT :: ModuleSRTInfo
_topSRT, cmmgroup :: CmmGroup
cmmgroup) <-
                  HscEnv -> ModuleSRTInfo -> CmmGroup -> IO (ModuleSRTInfo, CmmGroup)
cmmPipeline HscEnv
hsc_env (Module -> ModuleSRTInfo
emptySRT Module
this_mod) CmmGroup
cmmgroup
                (a, CmmGroup) -> IO (a, CmmGroup)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
us, CmmGroup
cmmgroup)

          in do UniqSupply
_ <- (UniqSupply -> CmmGroup -> IO (UniqSupply, CmmGroup))
-> UniqSupply
-> Stream IO CmmGroup ()
-> Stream IO CmmGroup UniqSupply
forall (m :: * -> *) c a b.
Monad m =>
(c -> a -> m (c, b)) -> c -> Stream m a () -> Stream m b c
Stream.mapAccumL UniqSupply -> CmmGroup -> IO (UniqSupply, CmmGroup)
forall a. a -> CmmGroup -> IO (a, CmmGroup)
run_pipeline UniqSupply
us Stream IO CmmGroup ()
ppr_stream1
                () -> Stream IO CmmGroup ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      | Bool
otherwise
        = {-# SCC "cmmPipeline" #-}
          let run_pipeline :: ModuleSRTInfo -> CmmGroup -> IO (ModuleSRTInfo, CmmGroup)
run_pipeline = HscEnv -> ModuleSRTInfo -> CmmGroup -> IO (ModuleSRTInfo, CmmGroup)
cmmPipeline HscEnv
hsc_env
          in Stream IO CmmGroup ModuleSRTInfo -> Stream IO CmmGroup ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Stream IO CmmGroup ModuleSRTInfo -> Stream IO CmmGroup ())
-> Stream IO CmmGroup ModuleSRTInfo -> Stream IO CmmGroup ()
forall a b. (a -> b) -> a -> b
$ (ModuleSRTInfo -> CmmGroup -> IO (ModuleSRTInfo, CmmGroup))
-> ModuleSRTInfo
-> Stream IO CmmGroup ()
-> Stream IO CmmGroup ModuleSRTInfo
forall (m :: * -> *) c a b.
Monad m =>
(c -> a -> m (c, b)) -> c -> Stream m a () -> Stream m b c
Stream.mapAccumL ModuleSRTInfo -> CmmGroup -> IO (ModuleSRTInfo, CmmGroup)
run_pipeline (Module -> ModuleSRTInfo
emptySRT Module
this_mod) Stream IO CmmGroup ()
ppr_stream1

    let
        dump2 :: b -> IO b
dump2 a :: b
a = do DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_cmm
                        "Output Cmm" (b -> SDoc
forall a. Outputable a => a -> SDoc
ppr b
a)
                     b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
a

        ppr_stream2 :: Stream IO CmmGroup ()
ppr_stream2 = (CmmGroup -> IO CmmGroup)
-> Stream IO CmmGroup () -> Stream IO CmmGroup ()
forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> Stream m a x -> Stream m b x
Stream.mapM CmmGroup -> IO CmmGroup
forall b. Outputable b => b -> IO b
dump2 Stream IO CmmGroup ()
pipeline_stream

    Stream IO CmmGroup () -> IO (Stream IO CmmGroup ())
forall (m :: * -> *) a. Monad m => a -> m a
return Stream IO CmmGroup ()
ppr_stream2



myCoreToStg :: DynFlags -> Module -> CoreProgram
            -> IO ( [StgTopBinding] -- output program
                  , CollectedCCs )  -- CAF cost centre info (declared and used)
myCoreToStg :: DynFlags
-> Module -> CoreProgram -> IO ([StgTopBinding], CollectedCCs)
myCoreToStg dflags :: DynFlags
dflags this_mod :: Module
this_mod prepd_binds :: CoreProgram
prepd_binds = do
    let (stg_binds :: [StgTopBinding]
stg_binds, cost_centre_info :: CollectedCCs
cost_centre_info)
         = {-# SCC "Core2Stg" #-}
           DynFlags
-> Module -> CoreProgram -> ([StgTopBinding], CollectedCCs)
coreToStg DynFlags
dflags Module
this_mod CoreProgram
prepd_binds

    [StgTopBinding]
stg_binds2
        <- {-# SCC "Stg2Stg" #-}
           DynFlags -> Module -> [StgTopBinding] -> IO [StgTopBinding]
stg2stg DynFlags
dflags Module
this_mod [StgTopBinding]
stg_binds

    ([StgTopBinding], CollectedCCs)
-> IO ([StgTopBinding], CollectedCCs)
forall (m :: * -> *) a. Monad m => a -> m a
return ([StgTopBinding]
stg_binds2, CollectedCCs
cost_centre_info)


{- **********************************************************************
%*                                                                      *
\subsection{Compiling a do-statement}
%*                                                                      *
%********************************************************************* -}

{-
When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When
you run it you get a list of HValues that should be the same length as the list
of names; add them to the ClosureEnv.

A naked expression returns a singleton Name [it]. The stmt is lifted into the
IO monad as explained in Note [Interactively-bound Ids in GHCi] in HscTypes
-}

-- | Compile a stmt all the way to an HValue, but don't run it
--
-- We return Nothing to indicate an empty statement (or comment only), not a
-- parse error.
hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv))
hscStmt :: HscEnv -> String -> IO (Maybe ([DFunId], ForeignHValue, FixityEnv))
hscStmt hsc_env :: HscEnv
hsc_env stmt :: String
stmt = HscEnv
-> String
-> String
-> Int
-> IO (Maybe ([DFunId], ForeignHValue, FixityEnv))
hscStmtWithLocation HscEnv
hsc_env String
stmt "<interactive>" 1

-- | Compile a stmt all the way to an HValue, but don't run it
--
-- We return Nothing to indicate an empty statement (or comment only), not a
-- parse error.
hscStmtWithLocation :: HscEnv
                    -> String -- ^ The statement
                    -> String -- ^ The source
                    -> Int    -- ^ Starting line
                    -> IO ( Maybe ([Id]
                          , ForeignHValue {- IO [HValue] -}
                          , FixityEnv))
hscStmtWithLocation :: HscEnv
-> String
-> String
-> Int
-> IO (Maybe ([DFunId], ForeignHValue, FixityEnv))
hscStmtWithLocation hsc_env0 :: HscEnv
hsc_env0 stmt :: String
stmt source :: String
source linenumber :: Int
linenumber =
  HscEnv
-> Hsc (Maybe ([DFunId], ForeignHValue, FixityEnv))
-> IO (Maybe ([DFunId], ForeignHValue, FixityEnv))
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc (Maybe ([DFunId], ForeignHValue, FixityEnv))
 -> IO (Maybe ([DFunId], ForeignHValue, FixityEnv)))
-> Hsc (Maybe ([DFunId], ForeignHValue, FixityEnv))
-> IO (Maybe ([DFunId], ForeignHValue, FixityEnv))
forall a b. (a -> b) -> a -> b
$ do
    Maybe (GhciLStmt GhcPs)
maybe_stmt <- String -> Int -> String -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmtWithLocation String
source Int
linenumber String
stmt
    case Maybe (GhciLStmt GhcPs)
maybe_stmt of
      Nothing -> Maybe ([DFunId], ForeignHValue, FixityEnv)
-> Hsc (Maybe ([DFunId], ForeignHValue, FixityEnv))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ([DFunId], ForeignHValue, FixityEnv)
forall a. Maybe a
Nothing

      Just parsed_stmt :: GhciLStmt GhcPs
parsed_stmt -> do
        HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
        IO (Maybe ([DFunId], ForeignHValue, FixityEnv))
-> Hsc (Maybe ([DFunId], ForeignHValue, FixityEnv))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ([DFunId], ForeignHValue, FixityEnv))
 -> Hsc (Maybe ([DFunId], ForeignHValue, FixityEnv)))
-> IO (Maybe ([DFunId], ForeignHValue, FixityEnv))
-> Hsc (Maybe ([DFunId], ForeignHValue, FixityEnv))
forall a b. (a -> b) -> a -> b
$ HscEnv
-> GhciLStmt GhcPs
-> IO (Maybe ([DFunId], ForeignHValue, FixityEnv))
hscParsedStmt HscEnv
hsc_env GhciLStmt GhcPs
parsed_stmt

hscParsedStmt :: HscEnv
              -> GhciLStmt GhcPs  -- ^ The parsed statement
              -> IO ( Maybe ([Id]
                    , ForeignHValue {- IO [HValue] -}
                    , FixityEnv))
hscParsedStmt :: HscEnv
-> GhciLStmt GhcPs
-> IO (Maybe ([DFunId], ForeignHValue, FixityEnv))
hscParsedStmt hsc_env :: HscEnv
hsc_env stmt :: GhciLStmt GhcPs
stmt = HscEnv
-> Hsc (Maybe ([DFunId], ForeignHValue, FixityEnv))
-> IO (Maybe ([DFunId], ForeignHValue, FixityEnv))
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env (Hsc (Maybe ([DFunId], ForeignHValue, FixityEnv))
 -> IO (Maybe ([DFunId], ForeignHValue, FixityEnv)))
-> Hsc (Maybe ([DFunId], ForeignHValue, FixityEnv))
-> IO (Maybe ([DFunId], ForeignHValue, FixityEnv))
forall a b. (a -> b) -> a -> b
$ do
  -- Rename and typecheck it
  (ids :: [DFunId]
ids, tc_expr :: LHsExpr GhcTc
tc_expr, fix_env :: FixityEnv
fix_env) <- IO
  ((WarningMessages, WarningMessages),
   Maybe ([DFunId], LHsExpr GhcTc, FixityEnv))
-> Hsc ([DFunId], LHsExpr GhcTc, FixityEnv)
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO
   ((WarningMessages, WarningMessages),
    Maybe ([DFunId], LHsExpr GhcTc, FixityEnv))
 -> Hsc ([DFunId], LHsExpr GhcTc, FixityEnv))
-> IO
     ((WarningMessages, WarningMessages),
      Maybe ([DFunId], LHsExpr GhcTc, FixityEnv))
-> Hsc ([DFunId], LHsExpr GhcTc, FixityEnv)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> GhciLStmt GhcPs
-> IO
     ((WarningMessages, WarningMessages),
      Maybe ([DFunId], LHsExpr GhcTc, FixityEnv))
tcRnStmt HscEnv
hsc_env GhciLStmt GhcPs
stmt

  -- Desugar it
  CoreExpr
ds_expr <- IO ((WarningMessages, WarningMessages), Maybe CoreExpr)
-> Hsc CoreExpr
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO ((WarningMessages, WarningMessages), Maybe CoreExpr)
 -> Hsc CoreExpr)
-> IO ((WarningMessages, WarningMessages), Maybe CoreExpr)
-> Hsc CoreExpr
forall a b. (a -> b) -> a -> b
$ HscEnv
-> LHsExpr GhcTc
-> IO ((WarningMessages, WarningMessages), Maybe CoreExpr)
deSugarExpr HscEnv
hsc_env LHsExpr GhcTc
tc_expr
  IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> HscEnv -> CoreExpr -> IO ()
lintInteractiveExpr "desugar expression" HscEnv
hsc_env CoreExpr
ds_expr)
  Hsc ()
handleWarnings

  -- Then code-gen, and link it
  -- It's important NOT to have package 'interactive' as thisUnitId
  -- for linking, else we try to link 'main' and can't find it.
  -- Whereas the linker already knows to ignore 'interactive'
  let src_span :: SrcSpan
src_span = SrcLoc -> SrcSpan
srcLocSpan SrcLoc
interactiveSrcLoc
  ForeignHValue
hval <- IO ForeignHValue -> Hsc ForeignHValue
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ForeignHValue -> Hsc ForeignHValue)
-> IO ForeignHValue -> Hsc ForeignHValue
forall a b. (a -> b) -> a -> b
$ HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr HscEnv
hsc_env SrcSpan
src_span CoreExpr
ds_expr

  Maybe ([DFunId], ForeignHValue, FixityEnv)
-> Hsc (Maybe ([DFunId], ForeignHValue, FixityEnv))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ([DFunId], ForeignHValue, FixityEnv)
 -> Hsc (Maybe ([DFunId], ForeignHValue, FixityEnv)))
-> Maybe ([DFunId], ForeignHValue, FixityEnv)
-> Hsc (Maybe ([DFunId], ForeignHValue, FixityEnv))
forall a b. (a -> b) -> a -> b
$ ([DFunId], ForeignHValue, FixityEnv)
-> Maybe ([DFunId], ForeignHValue, FixityEnv)
forall a. a -> Maybe a
Just ([DFunId]
ids, ForeignHValue
hval, FixityEnv
fix_env)

-- | Compile a decls
hscDecls :: HscEnv
         -> String -- ^ The statement
         -> IO ([TyThing], InteractiveContext)
hscDecls :: HscEnv -> String -> IO ([TyThing], InteractiveContext)
hscDecls hsc_env :: HscEnv
hsc_env str :: String
str = HscEnv
-> String -> String -> Int -> IO ([TyThing], InteractiveContext)
hscDeclsWithLocation HscEnv
hsc_env String
str "<interactive>" 1

hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs]
hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs]
hscParseDeclsWithLocation hsc_env :: HscEnv
hsc_env source :: String
source line_num :: Int
line_num str :: String
str = do
    L _ (HsModule{ hsmodDecls :: forall pass. HsModule pass -> [LHsDecl pass]
hsmodDecls = [LHsDecl GhcPs]
decls }) <-
      HscEnv
-> Hsc (Located (HsModule GhcPs)) -> IO (Located (HsModule GhcPs))
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env (Hsc (Located (HsModule GhcPs)) -> IO (Located (HsModule GhcPs)))
-> Hsc (Located (HsModule GhcPs)) -> IO (Located (HsModule GhcPs))
forall a b. (a -> b) -> a -> b
$
        String
-> Int
-> P (Located (HsModule GhcPs))
-> String
-> Hsc (Located (HsModule GhcPs))
forall thing.
(Outputable thing, Data thing) =>
String -> Int -> P thing -> String -> Hsc thing
hscParseThingWithLocation String
source Int
line_num P (Located (HsModule GhcPs))
parseModule String
str
    [LHsDecl GhcPs] -> IO [LHsDecl GhcPs]
forall (m :: * -> *) a. Monad m => a -> m a
return [LHsDecl GhcPs]
decls

-- | Compile a decls
hscDeclsWithLocation :: HscEnv
                     -> String -- ^ The statement
                     -> String -- ^ The source
                     -> Int    -- ^ Starting line
                     -> IO ([TyThing], InteractiveContext)
hscDeclsWithLocation :: HscEnv
-> String -> String -> Int -> IO ([TyThing], InteractiveContext)
hscDeclsWithLocation hsc_env :: HscEnv
hsc_env str :: String
str source :: String
source linenumber :: Int
linenumber = do
    L _ (HsModule{ hsmodDecls :: forall pass. HsModule pass -> [LHsDecl pass]
hsmodDecls = [LHsDecl GhcPs]
decls }) <-
      HscEnv
-> Hsc (Located (HsModule GhcPs)) -> IO (Located (HsModule GhcPs))
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env (Hsc (Located (HsModule GhcPs)) -> IO (Located (HsModule GhcPs)))
-> Hsc (Located (HsModule GhcPs)) -> IO (Located (HsModule GhcPs))
forall a b. (a -> b) -> a -> b
$
        String
-> Int
-> P (Located (HsModule GhcPs))
-> String
-> Hsc (Located (HsModule GhcPs))
forall thing.
(Outputable thing, Data thing) =>
String -> Int -> P thing -> String -> Hsc thing
hscParseThingWithLocation String
source Int
linenumber P (Located (HsModule GhcPs))
parseModule String
str
    HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)
hscParsedDecls HscEnv
hsc_env [LHsDecl GhcPs]
decls

hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)
hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)
hscParsedDecls hsc_env :: HscEnv
hsc_env decls :: [LHsDecl GhcPs]
decls = HscEnv
-> Hsc ([TyThing], InteractiveContext)
-> IO ([TyThing], InteractiveContext)
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env (Hsc ([TyThing], InteractiveContext)
 -> IO ([TyThing], InteractiveContext))
-> Hsc ([TyThing], InteractiveContext)
-> IO ([TyThing], InteractiveContext)
forall a b. (a -> b) -> a -> b
$ do
    {- Rename and typecheck it -}
    HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
    TcGblEnv
tc_gblenv <- IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
-> Hsc TcGblEnv
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
 -> Hsc TcGblEnv)
-> IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
-> Hsc TcGblEnv
forall a b. (a -> b) -> a -> b
$ HscEnv
-> [LHsDecl GhcPs]
-> IO ((WarningMessages, WarningMessages), Maybe TcGblEnv)
tcRnDeclsi HscEnv
hsc_env [LHsDecl GhcPs]
decls

    {- Grab the new instances -}
    -- We grab the whole environment because of the overlapping that may have
    -- been done. See the notes at the definition of InteractiveContext
    -- (ic_instances) for more details.
    let defaults :: Maybe [Type]
defaults = TcGblEnv -> Maybe [Type]
tcg_default TcGblEnv
tc_gblenv

    {- Desugar it -}
    -- We use a basically null location for iNTERACTIVE
    let iNTERACTIVELoc :: ModLocation
iNTERACTIVELoc = ModLocation :: Maybe String -> String -> String -> String -> ModLocation
ModLocation{ ml_hs_file :: Maybe String
ml_hs_file   = Maybe String
forall a. Maybe a
Nothing,
                                      ml_hi_file :: String
ml_hi_file   = String -> String
forall a. String -> a
panic "hsDeclsWithLocation:ml_hi_file",
                                      ml_obj_file :: String
ml_obj_file  = String -> String
forall a. String -> a
panic "hsDeclsWithLocation:ml_obj_file",
                                      ml_hie_file :: String
ml_hie_file  = String -> String
forall a. String -> a
panic "hsDeclsWithLocation:ml_hie_file" }
    ModGuts
ds_result <- ModLocation -> TcGblEnv -> Hsc ModGuts
hscDesugar' ModLocation
iNTERACTIVELoc TcGblEnv
tc_gblenv

    {- Simplify -}
    ModGuts
simpl_mg <- IO ModGuts -> Hsc ModGuts
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModGuts -> Hsc ModGuts) -> IO ModGuts -> Hsc ModGuts
forall a b. (a -> b) -> a -> b
$ do
      [String]
plugins <- IORef [String] -> IO [String]
forall a. IORef a -> IO a
readIORef (TcGblEnv -> IORef [String]
tcg_th_coreplugins TcGblEnv
tc_gblenv)
      HscEnv -> [String] -> ModGuts -> IO ModGuts
hscSimplify HscEnv
hsc_env [String]
plugins ModGuts
ds_result

    {- Tidy -}
    (tidy_cg :: CgGuts
tidy_cg, mod_details :: ModDetails
mod_details) <- IO (CgGuts, ModDetails) -> Hsc (CgGuts, ModDetails)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (CgGuts, ModDetails) -> Hsc (CgGuts, ModDetails))
-> IO (CgGuts, ModDetails) -> Hsc (CgGuts, ModDetails)
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
tidyProgram HscEnv
hsc_env ModGuts
simpl_mg

    let !CgGuts{ cg_module :: CgGuts -> Module
cg_module    = Module
this_mod,
                 cg_binds :: CgGuts -> CoreProgram
cg_binds     = CoreProgram
core_binds,
                 cg_tycons :: CgGuts -> [TyCon]
cg_tycons    = [TyCon]
tycons,
                 cg_modBreaks :: CgGuts -> Maybe ModBreaks
cg_modBreaks = Maybe ModBreaks
mod_breaks } = CgGuts
tidy_cg

        !ModDetails { md_insts :: ModDetails -> [ClsInst]
md_insts     = [ClsInst]
cls_insts
                    , md_fam_insts :: ModDetails -> [FamInst]
md_fam_insts = [FamInst]
fam_insts } = ModDetails
mod_details
            -- Get the *tidied* cls_insts and fam_insts

        data_tycons :: [TyCon]
data_tycons = (TyCon -> Bool) -> [TyCon] -> [TyCon]
forall a. (a -> Bool) -> [a] -> [a]
filter TyCon -> Bool
isDataTyCon [TyCon]
tycons

    {- Prepare For Code Generation -}
    -- Do saturation and convert to A-normal form
    (prepd_binds :: CoreProgram
prepd_binds, _) <- {-# SCC "CorePrep" #-}
      IO (CoreProgram, Set CostCentre)
-> Hsc (CoreProgram, Set CostCentre)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (CoreProgram, Set CostCentre)
 -> Hsc (CoreProgram, Set CostCentre))
-> IO (CoreProgram, Set CostCentre)
-> Hsc (CoreProgram, Set CostCentre)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Module
-> ModLocation
-> CoreProgram
-> [TyCon]
-> IO (CoreProgram, Set CostCentre)
corePrepPgm HscEnv
hsc_env Module
this_mod ModLocation
iNTERACTIVELoc CoreProgram
core_binds [TyCon]
data_tycons

    {- Generate byte code -}
    CompiledByteCode
cbc <- IO CompiledByteCode -> Hsc CompiledByteCode
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CompiledByteCode -> Hsc CompiledByteCode)
-> IO CompiledByteCode -> Hsc CompiledByteCode
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Module
-> CoreProgram
-> [TyCon]
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen HscEnv
hsc_env Module
this_mod
                                CoreProgram
prepd_binds [TyCon]
data_tycons Maybe ModBreaks
mod_breaks

    let src_span :: SrcSpan
src_span = SrcLoc -> SrcSpan
srcLocSpan SrcLoc
interactiveSrcLoc
    IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> SrcSpan -> CompiledByteCode -> IO ()
linkDecls HscEnv
hsc_env SrcSpan
src_span CompiledByteCode
cbc

    {- Load static pointer table entries -}
    IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> [SptEntry] -> IO ()
hscAddSptEntries HscEnv
hsc_env (CgGuts -> [SptEntry]
cg_spt_entries CgGuts
tidy_cg)

    let tcs :: [TyCon]
tcs = (TyCon -> Bool) -> [TyCon] -> [TyCon]
forall a. (a -> Bool) -> [a] -> [a]
filterOut TyCon -> Bool
isImplicitTyCon (ModGuts -> [TyCon]
mg_tcs ModGuts
simpl_mg)
        patsyns :: [PatSyn]
patsyns = ModGuts -> [PatSyn]
mg_patsyns ModGuts
simpl_mg

        ext_ids :: [DFunId]
ext_ids = [ DFunId
id | DFunId
id <- CoreProgram -> [DFunId]
forall b. [Bind b] -> [b]
bindersOfBinds CoreProgram
core_binds
                       , Name -> Bool
isExternalName (DFunId -> Name
idName DFunId
id)
                       , Bool -> Bool
not (DFunId -> Bool
isDFunId DFunId
id Bool -> Bool -> Bool
|| DFunId -> Bool
isImplicitId DFunId
id) ]
            -- We only need to keep around the external bindings
            -- (as decided by TidyPgm), since those are the only ones
            -- that might later be looked up by name.  But we can exclude
            --    - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in HscTypes
            --    - Implicit Ids, which are implicit in tcs
            -- c.f. TcRnDriver.runTcInteractive, which reconstructs the TypeEnv

        new_tythings :: [TyThing]
new_tythings = (DFunId -> TyThing) -> [DFunId] -> [TyThing]
forall a b. (a -> b) -> [a] -> [b]
map DFunId -> TyThing
AnId [DFunId]
ext_ids [TyThing] -> [TyThing] -> [TyThing]
forall a. [a] -> [a] -> [a]
++ (TyCon -> TyThing) -> [TyCon] -> [TyThing]
forall a b. (a -> b) -> [a] -> [b]
map TyCon -> TyThing
ATyCon [TyCon]
tcs [TyThing] -> [TyThing] -> [TyThing]
forall a. [a] -> [a] -> [a]
++ (PatSyn -> TyThing) -> [PatSyn] -> [TyThing]
forall a b. (a -> b) -> [a] -> [b]
map (ConLike -> TyThing
AConLike (ConLike -> TyThing) -> (PatSyn -> ConLike) -> PatSyn -> TyThing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatSyn -> ConLike
PatSynCon) [PatSyn]
patsyns
        ictxt :: InteractiveContext
ictxt        = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
        -- See Note [Fixity declarations in GHCi]
        fix_env :: FixityEnv
fix_env      = TcGblEnv -> FixityEnv
tcg_fix_env TcGblEnv
tc_gblenv
        new_ictxt :: InteractiveContext
new_ictxt    = InteractiveContext
-> [TyThing]
-> [ClsInst]
-> [FamInst]
-> Maybe [Type]
-> FixityEnv
-> InteractiveContext
extendInteractiveContext InteractiveContext
ictxt [TyThing]
new_tythings [ClsInst]
cls_insts
                                                [FamInst]
fam_insts Maybe [Type]
defaults FixityEnv
fix_env
    ([TyThing], InteractiveContext)
-> Hsc ([TyThing], InteractiveContext)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyThing]
new_tythings, InteractiveContext
new_ictxt)

-- | Load the given static-pointer table entries into the interpreter.
-- See Note [Grand plan for static forms] in StaticPtrTable.
hscAddSptEntries :: HscEnv -> [SptEntry] -> IO ()
hscAddSptEntries :: HscEnv -> [SptEntry] -> IO ()
hscAddSptEntries hsc_env :: HscEnv
hsc_env entries :: [SptEntry]
entries = do
    let add_spt_entry :: SptEntry -> IO ()
        add_spt_entry :: SptEntry -> IO ()
add_spt_entry (SptEntry i :: DFunId
i fpr :: Fingerprint
fpr) = do
            ForeignHValue
val <- HscEnv -> Name -> IO ForeignHValue
getHValue HscEnv
hsc_env (DFunId -> Name
idName DFunId
i)
            HscEnv -> Fingerprint -> ForeignHValue -> IO ()
addSptEntry HscEnv
hsc_env Fingerprint
fpr ForeignHValue
val
    (SptEntry -> IO ()) -> [SptEntry] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SptEntry -> IO ()
add_spt_entry [SptEntry]
entries

{-
  Note [Fixity declarations in GHCi]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  To support fixity declarations on types defined within GHCi (as requested
  in #10018) we record the fixity environment in InteractiveContext.
  When we want to evaluate something TcRnDriver.runTcInteractive pulls out this
  fixity environment and uses it to initialize the global typechecker environment.
  After the typechecker has finished its business, an updated fixity environment
  (reflecting whatever fixity declarations were present in the statements we
  passed it) will be returned from hscParsedStmt. This is passed to
  updateFixityEnv, which will stuff it back into InteractiveContext, to be
  used in evaluating the next statement.

-}

hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs)
hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs)
hscImport hsc_env :: HscEnv
hsc_env str :: String
str = HscEnv -> Hsc (ImportDecl GhcPs) -> IO (ImportDecl GhcPs)
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env (Hsc (ImportDecl GhcPs) -> IO (ImportDecl GhcPs))
-> Hsc (ImportDecl GhcPs) -> IO (ImportDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ do
    (L _ (HsModule{hsmodImports :: forall pass. HsModule pass -> [LImportDecl pass]
hsmodImports=[LImportDecl GhcPs]
is})) <-
       P (Located (HsModule GhcPs))
-> String -> Hsc (Located (HsModule GhcPs))
forall thing.
(Outputable thing, Data thing) =>
P thing -> String -> Hsc thing
hscParseThing P (Located (HsModule GhcPs))
parseModule String
str
    case [LImportDecl GhcPs]
is of
        [L _ i :: ImportDecl GhcPs
i] -> ImportDecl GhcPs -> Hsc (ImportDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return ImportDecl GhcPs
i
        _ -> IO (ImportDecl GhcPs) -> Hsc (ImportDecl GhcPs)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ImportDecl GhcPs) -> Hsc (ImportDecl GhcPs))
-> IO (ImportDecl GhcPs) -> Hsc (ImportDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ ErrMsg -> IO (ImportDecl GhcPs)
forall (m :: * -> *) ab. MonadIO m => ErrMsg -> m ab
throwOneError (ErrMsg -> IO (ImportDecl GhcPs))
-> ErrMsg -> IO (ImportDecl GhcPs)
forall a b. (a -> b) -> a -> b
$
                 DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) SrcSpan
noSrcSpan (SDoc -> ErrMsg) -> SDoc -> ErrMsg
forall a b. (a -> b) -> a -> b
$
                     String -> SDoc
text "parse error in import declaration"

-- | Typecheck an expression (but don't run it)
hscTcExpr :: HscEnv
          -> TcRnExprMode
          -> String -- ^ The expression
          -> IO Type
hscTcExpr :: HscEnv -> TcRnExprMode -> String -> IO Type
hscTcExpr hsc_env0 :: HscEnv
hsc_env0 mode :: TcRnExprMode
mode expr :: String
expr = HscEnv -> Hsc Type -> IO Type
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc Type -> IO Type) -> Hsc Type -> IO Type
forall a b. (a -> b) -> a -> b
$ do
  HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
  LHsExpr GhcPs
parsed_expr <- String -> Hsc (LHsExpr GhcPs)
hscParseExpr String
expr
  IO ((WarningMessages, WarningMessages), Maybe Type) -> Hsc Type
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO ((WarningMessages, WarningMessages), Maybe Type) -> Hsc Type)
-> IO ((WarningMessages, WarningMessages), Maybe Type) -> Hsc Type
forall a b. (a -> b) -> a -> b
$ HscEnv
-> TcRnExprMode
-> LHsExpr GhcPs
-> IO ((WarningMessages, WarningMessages), Maybe Type)
tcRnExpr HscEnv
hsc_env TcRnExprMode
mode LHsExpr GhcPs
parsed_expr

-- | Find the kind of a type, after generalisation
hscKcType
  :: HscEnv
  -> Bool            -- ^ Normalise the type
  -> String          -- ^ The type as a string
  -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind
hscKcType :: HscEnv -> Bool -> String -> IO (Type, Type)
hscKcType hsc_env0 :: HscEnv
hsc_env0 normalise :: Bool
normalise str :: String
str = HscEnv -> Hsc (Type, Type) -> IO (Type, Type)
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc (Type, Type) -> IO (Type, Type))
-> Hsc (Type, Type) -> IO (Type, Type)
forall a b. (a -> b) -> a -> b
$ do
    HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
    LHsType GhcPs
ty <- String -> Hsc (LHsType GhcPs)
hscParseType String
str
    IO ((WarningMessages, WarningMessages), Maybe (Type, Type))
-> Hsc (Type, Type)
forall a. IO ((WarningMessages, WarningMessages), Maybe a) -> Hsc a
ioMsgMaybe (IO ((WarningMessages, WarningMessages), Maybe (Type, Type))
 -> Hsc (Type, Type))
-> IO ((WarningMessages, WarningMessages), Maybe (Type, Type))
-> Hsc (Type, Type)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Bool
-> LHsType GhcPs
-> IO ((WarningMessages, WarningMessages), Maybe (Type, Type))
tcRnType HscEnv
hsc_env Bool
normalise LHsType GhcPs
ty

hscParseExpr :: String -> Hsc (LHsExpr GhcPs)
hscParseExpr :: String -> Hsc (LHsExpr GhcPs)
hscParseExpr expr :: String
expr = do
  HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
  Maybe (GhciLStmt GhcPs)
maybe_stmt <- String -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmt String
expr
  case Maybe (GhciLStmt GhcPs)
maybe_stmt of
    Just (L _ (BodyStmt _ expr :: LHsExpr GhcPs
expr _ _)) -> LHsExpr GhcPs -> Hsc (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr GhcPs
expr
    _ -> WarningMessages -> Hsc (LHsExpr GhcPs)
forall (io :: * -> *) a. MonadIO io => WarningMessages -> io a
throwErrors (WarningMessages -> Hsc (LHsExpr GhcPs))
-> WarningMessages -> Hsc (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ ErrMsg -> WarningMessages
forall a. a -> Bag a
unitBag (ErrMsg -> WarningMessages) -> ErrMsg -> WarningMessages
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) SrcSpan
noSrcSpan
      (String -> SDoc
text "not an expression:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
expr))

hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmt = P (Maybe (GhciLStmt GhcPs))
-> String -> Hsc (Maybe (GhciLStmt GhcPs))
forall thing.
(Outputable thing, Data thing) =>
P thing -> String -> Hsc thing
hscParseThing P (Maybe (GhciLStmt GhcPs))
parseStmt

hscParseStmtWithLocation :: String -> Int -> String
                         -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmtWithLocation :: String -> Int -> String -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmtWithLocation source :: String
source linenumber :: Int
linenumber stmt :: String
stmt =
    String
-> Int
-> P (Maybe (GhciLStmt GhcPs))
-> String
-> Hsc (Maybe (GhciLStmt GhcPs))
forall thing.
(Outputable thing, Data thing) =>
String -> Int -> P thing -> String -> Hsc thing
hscParseThingWithLocation String
source Int
linenumber P (Maybe (GhciLStmt GhcPs))
parseStmt String
stmt

hscParseType :: String -> Hsc (LHsType GhcPs)
hscParseType :: String -> Hsc (LHsType GhcPs)
hscParseType = P (LHsType GhcPs) -> String -> Hsc (LHsType GhcPs)
forall thing.
(Outputable thing, Data thing) =>
P thing -> String -> Hsc thing
hscParseThing P (LHsType GhcPs)
parseType

hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)
hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)
hscParseIdentifier hsc_env :: HscEnv
hsc_env str :: String
str =
    HscEnv -> Hsc (Located RdrName) -> IO (Located RdrName)
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env (Hsc (Located RdrName) -> IO (Located RdrName))
-> Hsc (Located RdrName) -> IO (Located RdrName)
forall a b. (a -> b) -> a -> b
$ P (Located RdrName) -> String -> Hsc (Located RdrName)
forall thing.
(Outputable thing, Data thing) =>
P thing -> String -> Hsc thing
hscParseThing P (Located RdrName)
parseIdentifier String
str

hscParseThing :: (Outputable thing, Data thing)
              => Lexer.P thing -> String -> Hsc thing
hscParseThing :: P thing -> String -> Hsc thing
hscParseThing = String -> Int -> P thing -> String -> Hsc thing
forall thing.
(Outputable thing, Data thing) =>
String -> Int -> P thing -> String -> Hsc thing
hscParseThingWithLocation "<interactive>" 1

hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int
                          -> Lexer.P thing -> String -> Hsc thing
hscParseThingWithLocation :: String -> Int -> P thing -> String -> Hsc thing
hscParseThingWithLocation source :: String
source linenumber :: Int
linenumber parser :: P thing
parser str :: String
str
  = Hsc DynFlags -> SDoc -> (thing -> ()) -> Hsc thing -> Hsc thing
forall (m :: * -> *) a.
MonadIO m =>
m DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
               (String -> SDoc
text "Parser [source]")
               (() -> thing -> ()
forall a b. a -> b -> a
const ()) (Hsc thing -> Hsc thing) -> Hsc thing -> Hsc thing
forall a b. (a -> b) -> a -> b
$ {-# SCC "Parser" #-} do
    DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

    let buf :: StringBuffer
buf = String -> StringBuffer
stringToStringBuffer String
str
        loc :: RealSrcLoc
loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
fsLit String
source) Int
linenumber 1

    case P thing -> PState -> ParseResult thing
forall a. P a -> PState -> ParseResult a
unP P thing
parser (DynFlags -> StringBuffer -> RealSrcLoc -> PState
mkPState DynFlags
dflags StringBuffer
buf RealSrcLoc
loc) of
        PFailed warnFn :: DynFlags -> (WarningMessages, WarningMessages)
warnFn span :: SrcSpan
span err :: SDoc
err -> do
            (WarningMessages, WarningMessages) -> Hsc ()
logWarningsReportErrors (DynFlags -> (WarningMessages, WarningMessages)
warnFn DynFlags
dflags)
            Hsc ()
handleWarnings
            let msg :: ErrMsg
msg = DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg DynFlags
dflags SrcSpan
span SDoc
err
            WarningMessages -> Hsc thing
forall (io :: * -> *) a. MonadIO io => WarningMessages -> io a
throwErrors (WarningMessages -> Hsc thing) -> WarningMessages -> Hsc thing
forall a b. (a -> b) -> a -> b
$ ErrMsg -> WarningMessages
forall a. a -> Bag a
unitBag ErrMsg
msg

        POk pst :: PState
pst thing :: thing
thing -> do
            (WarningMessages, WarningMessages) -> Hsc ()
logWarningsReportErrors (PState -> DynFlags -> (WarningMessages, WarningMessages)
getMessages PState
pst DynFlags
dflags)
            IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_parsed "Parser" (thing -> SDoc
forall a. Outputable a => a -> SDoc
ppr thing
thing)
            IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_parsed_ast "Parser AST" (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
                                   BlankSrcSpan -> thing -> SDoc
forall a. Data a => BlankSrcSpan -> a -> SDoc
showAstData BlankSrcSpan
NoBlankSrcSpan thing
thing
            thing -> Hsc thing
forall (m :: * -> *) a. Monad m => a -> m a
return thing
thing


{- **********************************************************************
%*                                                                      *
        Desugar, simplify, convert to bytecode, and link an expression
%*                                                                      *
%********************************************************************* -}

hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr hsc_env :: HscEnv
hsc_env =
  (Hooks
 -> Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue))
-> (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue)
-> DynFlags
-> HscEnv
-> SrcSpan
-> CoreExpr
-> IO ForeignHValue
forall a. (Hooks -> Maybe a) -> a -> DynFlags -> a
lookupHook Hooks -> Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue)
hscCompileCoreExprHook HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr' (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) HscEnv
hsc_env

hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr' hsc_env :: HscEnv
hsc_env srcspan :: SrcSpan
srcspan ds_expr :: CoreExpr
ds_expr
    = do { let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

           {- Simplify it -}
         ; CoreExpr
simpl_expr <- DynFlags -> CoreExpr -> IO CoreExpr
simplifyExpr DynFlags
dflags CoreExpr
ds_expr

           {- Tidy it (temporary, until coreSat does cloning) -}
         ; let tidy_expr :: CoreExpr
tidy_expr = TidyEnv -> CoreExpr -> CoreExpr
tidyExpr TidyEnv
emptyTidyEnv CoreExpr
simpl_expr

           {- Prepare for codegen -}
         ; CoreExpr
prepd_expr <- DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
corePrepExpr DynFlags
dflags HscEnv
hsc_env CoreExpr
tidy_expr

           {- Lint if necessary -}
         ; String -> HscEnv -> CoreExpr -> IO ()
lintInteractiveExpr "hscCompileExpr" HscEnv
hsc_env CoreExpr
prepd_expr

           {- Convert to BCOs -}
         ; UnlinkedBCO
bcos <- HscEnv -> Module -> CoreExpr -> IO UnlinkedBCO
coreExprToBCOs HscEnv
hsc_env
                     (InteractiveContext -> Module
icInteractiveModule (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)) CoreExpr
prepd_expr

           {- link it -}
         ; ForeignHValue
hval <- HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue
linkExpr HscEnv
hsc_env SrcSpan
srcspan UnlinkedBCO
bcos

         ; ForeignHValue -> IO ForeignHValue
forall (m :: * -> *) a. Monad m => a -> m a
return ForeignHValue
hval }


{- **********************************************************************
%*                                                                      *
        Statistics on reading interfaces
%*                                                                      *
%********************************************************************* -}

dumpIfaceStats :: HscEnv -> IO ()
dumpIfaceStats :: HscEnv -> IO ()
dumpIfaceStats hsc_env :: HscEnv
hsc_env = do
    ExternalPackageState
eps <- IORef ExternalPackageState -> IO ExternalPackageState
forall a. IORef a -> IO a
readIORef (HscEnv -> IORef ExternalPackageState
hsc_EPS HscEnv
hsc_env)
    DynFlags -> Bool -> String -> SDoc -> IO ()
dumpIfSet DynFlags
dflags (Bool
dump_if_trace Bool -> Bool -> Bool
|| Bool
dump_rn_stats)
              "Interface statistics"
              (ExternalPackageState -> SDoc
ifaceStats ExternalPackageState
eps)
  where
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    dump_rn_stats :: Bool
dump_rn_stats = DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_rn_stats DynFlags
dflags
    dump_if_trace :: Bool
dump_if_trace = DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_if_trace DynFlags
dflags


{- **********************************************************************
%*                                                                      *
        Progress Messages: Module i of n
%*                                                                      *
%********************************************************************* -}

showModuleIndex :: (Int, Int) -> String
showModuleIndex :: (Int, Int) -> String
showModuleIndex (i :: Int
i,n :: Int
n) = "[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
padded String -> String -> String
forall a. [a] -> [a] -> [a]
++ " of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n_str String -> String -> String
forall a. [a] -> [a] -> [a]
++ "] "
  where
    n_str :: String
n_str = Int -> String
forall a. Show a => a -> String
show Int
n
    i_str :: String
i_str = Int -> String
forall a. Show a => a -> String
show Int
i
    padded :: String
padded = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
n_str Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
i_str) ' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
i_str