{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
-- | This module introduces a \"lighter\" "GhcMonad" typeclass which doesn't require an instance of
-- 'ExceptionMonad', and can therefore be used for both 'CoreM' and 'Ghc'.
--

module Language.Haskell.Liquid.GHC.GhcMonadLike (
  -- * Types and type classes
    HasHscEnv
  , GhcMonadLike
  , ModuleInfo
  , TypecheckedModule(..)

  -- * Functions and typeclass methods

  , askHscEnv
  , getModuleGraph
  , getModSummary
  , lookupModSummary
  , lookupGlobalName
  , lookupName
  , modInfoLookupName
  , moduleInfoTc
  , parseModule
  , typecheckModule
  , desugarModule
  , findModule
  , lookupModule
  ) where

import Control.Monad
import Control.Monad.IO.Class
import Control.Exception (throwIO)

import Data.IORef (readIORef)

import qualified Language.Haskell.Liquid.GHC.API   as Ghc
import           Language.Haskell.Liquid.GHC.API   hiding ( ModuleInfo
                                                          , findModule
                                                          , desugarModule
                                                          , typecheckModule
                                                          , parseModule
                                                          , lookupName
                                                          , lookupGlobalName
                                                          , getModSummary
                                                          , getModuleGraph
                                                          , modInfoLookupName
                                                          , lookupModule
                                                          , TypecheckedModule
                                                          , tm_parsed_module
                                                          , tm_renamed_source
                                                          )
import qualified CoreMonad
import qualified EnumSet
import TcRnMonad
import Outputable
import UniqFM
import Maybes
import Panic
import GhcMake
import Finder
import Exception (ExceptionMonad)

import Optics

class HasHscEnv m where
  askHscEnv :: m HscEnv

instance HasHscEnv CoreMonad.CoreM where
  askHscEnv :: CoreM HscEnv
askHscEnv = CoreM HscEnv
CoreMonad.getHscEnv

instance HasHscEnv Ghc where
  askHscEnv :: Ghc HscEnv
askHscEnv = Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession

instance HasHscEnv (IfM lcl) where
  askHscEnv :: IfM lcl HscEnv
askHscEnv = IfM lcl HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv

instance HasHscEnv TcM where
  askHscEnv :: TcM HscEnv
askHscEnv = Env TcGblEnv TcLclEnv -> HscEnv
forall gbl lcl. Env gbl lcl -> HscEnv
env_top (Env TcGblEnv TcLclEnv -> HscEnv)
-> IOEnv (Env TcGblEnv TcLclEnv) (Env TcGblEnv TcLclEnv)
-> TcM HscEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) (Env TcGblEnv TcLclEnv)
forall env. IOEnv env env
getEnv

instance HasHscEnv Hsc where
  askHscEnv :: Hsc HscEnv
askHscEnv = (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
$ \HscEnv
e WarningMessages
w -> (HscEnv, WarningMessages) -> IO (HscEnv, WarningMessages)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HscEnv
e, WarningMessages
w)

instance (ExceptionMonad m, HasHscEnv m) => HasHscEnv (GhcT m) where
  askHscEnv :: GhcT m HscEnv
askHscEnv = GhcT m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession

-- | A typeclass which is /very/ similar to the existing 'GhcMonad', but it doesn't impose a
-- 'ExceptionMonad' constraint.
class (Functor m, MonadIO m, HasHscEnv m, HasDynFlags m) => GhcMonadLike m

instance GhcMonadLike CoreMonad.CoreM
instance GhcMonadLike Ghc
instance GhcMonadLike (IfM lcl)
instance GhcMonadLike TcM
instance GhcMonadLike Hsc
instance (ExceptionMonad m, GhcMonadLike m) => GhcMonadLike (GhcT m)

-- NOTE(adn) Taken from the GHC API, adapted to work for a 'GhcMonadLike' monad.
getModuleGraph :: GhcMonadLike m => m ModuleGraph
getModuleGraph :: m ModuleGraph
getModuleGraph = (HscEnv -> ModuleGraph) -> m HscEnv -> m ModuleGraph
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM HscEnv -> ModuleGraph
hsc_mod_graph m HscEnv
forall (m :: * -> *). HasHscEnv m => m HscEnv
askHscEnv

-- NOTE(adn) Taken from the GHC API, adapted to work for a 'GhcMonadLike' monad.
getModSummary :: GhcMonadLike m => ModuleName -> m ModSummary
getModSummary :: ModuleName -> m ModSummary
getModSummary ModuleName
mdl = do
   ModuleGraph
mg <- (HscEnv -> ModuleGraph) -> m HscEnv -> m ModuleGraph
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM HscEnv -> ModuleGraph
hsc_mod_graph m HscEnv
forall (m :: * -> *). HasHscEnv m => m HscEnv
askHscEnv
   let mods_by_name :: [ModSummary]
mods_by_name = [ ModSummary
ms | ModSummary
ms <- ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mg
                      , ModSummary -> ModuleName
ms_mod_name ModSummary
ms ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
mdl
                      , Bool -> Bool
not (ModSummary -> Bool
isBootSummary ModSummary
ms) ]
   case [ModSummary]
mods_by_name of
     [] -> do DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
              IO ModSummary -> m ModSummary
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModSummary -> m ModSummary) -> IO ModSummary -> m ModSummary
forall a b. (a -> b) -> a -> b
$ GhcApiError -> IO ModSummary
forall e a. Exception e => e -> IO a
throwIO (GhcApiError -> IO ModSummary) -> GhcApiError -> IO ModSummary
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> GhcApiError
mkApiErr DynFlags
dflags (String -> SDoc
text String
"Module not part of module graph")
     [ModSummary
ms] -> ModSummary -> m ModSummary
forall (m :: * -> *) a. Monad m => a -> m a
return ModSummary
ms
     [ModSummary]
multiple -> do DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                    IO ModSummary -> m ModSummary
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModSummary -> m ModSummary) -> IO ModSummary -> m ModSummary
forall a b. (a -> b) -> a -> b
$ GhcApiError -> IO ModSummary
forall e a. Exception e => e -> IO a
throwIO (GhcApiError -> IO ModSummary) -> GhcApiError -> IO ModSummary
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> GhcApiError
mkApiErr DynFlags
dflags (String -> SDoc
text String
"getModSummary is ambiguous: " SDoc -> SDoc -> SDoc
<+> [ModSummary] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModSummary]
multiple)

lookupModSummary :: GhcMonadLike m => ModuleName -> m (Maybe ModSummary)
lookupModSummary :: ModuleName -> m (Maybe ModSummary)
lookupModSummary ModuleName
mdl = do
   ModuleGraph
mg <- (HscEnv -> ModuleGraph) -> m HscEnv -> m ModuleGraph
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM HscEnv -> ModuleGraph
hsc_mod_graph m HscEnv
forall (m :: * -> *). HasHscEnv m => m HscEnv
askHscEnv
   let mods_by_name :: [ModSummary]
mods_by_name = [ ModSummary
ms | ModSummary
ms <- ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mg
                      , ModSummary -> ModuleName
ms_mod_name ModSummary
ms ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
mdl
                      , Bool -> Bool
not (ModSummary -> Bool
isBootSummary ModSummary
ms) ]
   case [ModSummary]
mods_by_name of
     [ModSummary
ms] -> Maybe ModSummary -> m (Maybe ModSummary)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModSummary -> Maybe ModSummary
forall a. a -> Maybe a
Just ModSummary
ms)
     [ModSummary]
_    -> Maybe ModSummary -> m (Maybe ModSummary)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ModSummary
forall a. Maybe a
Nothing

-- NOTE(adn) Taken from the GHC API, adapted to work for a 'GhcMonadLike' monad.
lookupGlobalName :: GhcMonadLike m => Name -> m (Maybe TyThing)
lookupGlobalName :: Name -> m (Maybe TyThing)
lookupGlobalName Name
name = do
  HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). HasHscEnv m => m HscEnv
askHscEnv
  IO (Maybe TyThing) -> m (Maybe TyThing)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe TyThing) -> m (Maybe TyThing))
-> IO (Maybe TyThing) -> m (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$ HscEnv -> Name -> IO (Maybe TyThing)
lookupTypeHscEnv HscEnv
hsc_env Name
name

-- NOTE(adn) Taken from the GHC API, adapted to work for a 'GhcMonadLike' monad.
lookupName :: GhcMonadLike m => Name -> m (Maybe TyThing)
lookupName :: Name -> m (Maybe TyThing)
lookupName Name
name = do
  HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). HasHscEnv m => m HscEnv
askHscEnv
  IO (Maybe TyThing) -> m (Maybe TyThing)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe TyThing) -> m (Maybe TyThing))
-> IO (Maybe TyThing) -> m (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$ HscEnv -> Name -> IO (Maybe TyThing)
hscTcRcLookupName HscEnv
hsc_env Name
name

-- | Our own simplified version of 'ModuleInfo' to overcome the fact we cannot construct the \"original\"
-- one as the constructor is not exported, and 'getHomeModuleInfo' and 'getPackageModuleInfo' are not
-- exported either, so we had to backport them as well.
data ModuleInfo = ModuleInfo { ModuleInfo -> UniqFM TyThing
minf_type_env :: UniqFM TyThing }

modInfoLookupName :: GhcMonadLike m 
                  => ModuleInfo 
                  -> Name
                  -> m (Maybe TyThing)
modInfoLookupName :: ModuleInfo -> Name -> m (Maybe TyThing)
modInfoLookupName ModuleInfo
minf Name
name = do
  HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). HasHscEnv m => m HscEnv
askHscEnv
  case UniqFM TyThing -> Name -> Maybe TyThing
lookupTypeEnv (ModuleInfo -> UniqFM TyThing
minf_type_env ModuleInfo
minf) Name
name of
    Just TyThing
tyThing -> Maybe TyThing -> m (Maybe TyThing)
forall (m :: * -> *) a. Monad m => a -> m a
return (TyThing -> Maybe TyThing
forall a. a -> Maybe a
Just TyThing
tyThing)
    Maybe TyThing
Nothing      -> do
      ExternalPackageState
eps   <- IO ExternalPackageState -> m ExternalPackageState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExternalPackageState -> m ExternalPackageState)
-> IO ExternalPackageState -> m ExternalPackageState
forall a b. (a -> b) -> a -> b
$ IORef ExternalPackageState -> IO ExternalPackageState
forall a. IORef a -> IO a
readIORef (HscEnv -> IORef ExternalPackageState
hsc_EPS HscEnv
hsc_env)
      Maybe TyThing -> m (Maybe TyThing)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TyThing -> m (Maybe TyThing))
-> Maybe TyThing -> m (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$! DynFlags
-> HomePackageTable -> UniqFM TyThing -> Name -> Maybe TyThing
lookupType (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) (ExternalPackageState -> UniqFM TyThing
eps_PTE ExternalPackageState
eps) Name
name

moduleInfoTc :: GhcMonadLike m => ModSummary -> TcGblEnv -> m ModuleInfo
moduleInfoTc :: ModSummary -> TcGblEnv -> m ModuleInfo
moduleInfoTc ModSummary
ms TcGblEnv
tcGblEnv = do
  HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). HasHscEnv m => m HscEnv
askHscEnv
  let hsc_env_tmp :: HscEnv
hsc_env_tmp = HscEnv
hsc_env { hsc_dflags :: DynFlags
hsc_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms }
  UniqFM TyThing
details <- ModDetails -> UniqFM TyThing
md_types (ModDetails -> UniqFM TyThing)
-> m ModDetails -> m (UniqFM TyThing)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ModDetails -> m ModDetails
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> TcGblEnv -> IO ModDetails
makeSimpleDetails HscEnv
hsc_env_tmp TcGblEnv
tcGblEnv)
  ModuleInfo -> m ModuleInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleInfo :: UniqFM TyThing -> ModuleInfo
ModuleInfo { minf_type_env :: UniqFM TyThing
minf_type_env = UniqFM TyThing
details }

--
-- Parsing, typechecking and desugaring a module
--
parseModule :: GhcMonadLike m => ModSummary -> m ParsedModule
parseModule :: ModSummary -> m ParsedModule
parseModule ModSummary
ms = do
  HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). HasHscEnv m => m HscEnv
askHscEnv
  let hsc_env_tmp :: HscEnv
hsc_env_tmp = HscEnv
hsc_env { hsc_dflags :: DynFlags
hsc_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms }
  HsParsedModule
hpm <- IO HsParsedModule -> m HsParsedModule
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HsParsedModule -> m HsParsedModule)
-> IO HsParsedModule -> m HsParsedModule
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> IO HsParsedModule
hscParse HscEnv
hsc_env_tmp ModSummary
ms
  ParsedModule -> m ParsedModule
forall (m :: * -> *) a. Monad m => a -> m a
return (ModSummary -> ParsedSource -> [String] -> ApiAnns -> ParsedModule
ParsedModule ModSummary
ms (HsParsedModule -> ParsedSource
hpm_module HsParsedModule
hpm) (HsParsedModule -> [String]
hpm_src_files HsParsedModule
hpm)
                           (HsParsedModule -> ApiAnns
hpm_annotations HsParsedModule
hpm))

-- | Our own simplified version of 'TypecheckedModule'.
data TypecheckedModule = TypecheckedModule { 
    TypecheckedModule -> ParsedModule
tm_parsed_module  :: ParsedModule
  , TypecheckedModule -> Maybe RenamedSource
tm_renamed_source :: Maybe RenamedSource
  , TypecheckedModule -> ModSummary
tm_mod_summary    :: ModSummary
  , TypecheckedModule -> TcGblEnv
tm_gbl_env        :: TcGblEnv
  }

typecheckModule :: GhcMonadLike m => ParsedModule -> m TypecheckedModule
typecheckModule :: ParsedModule -> m TypecheckedModule
typecheckModule ParsedModule
pmod = do
  -- Suppress all the warnings, so that they won't be printed (which would result in them being
  -- printed twice, one by GHC and once here).
  let ms :: ModSummary
ms = ParsedModule -> ModSummary
pm_mod_summary ParsedModule
pmod
  HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). HasHscEnv m => m HscEnv
askHscEnv
  let dynFlags' :: DynFlags
dynFlags' = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms
  let hsc_env_tmp :: HscEnv
hsc_env_tmp = HscEnv
hsc_env { hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dynFlags' { warningFlags :: EnumSet WarningFlag
warningFlags = EnumSet WarningFlag
forall a. EnumSet a
EnumSet.empty } }
  (TcGblEnv
tc_gbl_env, Maybe RenamedSource
rn_info)
        <- IO (TcGblEnv, Maybe RenamedSource)
-> m (TcGblEnv, Maybe RenamedSource)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TcGblEnv, Maybe RenamedSource)
 -> m (TcGblEnv, Maybe RenamedSource))
-> IO (TcGblEnv, Maybe RenamedSource)
-> m (TcGblEnv, Maybe RenamedSource)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> ModSummary
-> HsParsedModule
-> IO (TcGblEnv, Maybe RenamedSource)
hscTypecheckRename HscEnv
hsc_env_tmp ModSummary
ms (HsParsedModule -> IO (TcGblEnv, Maybe RenamedSource))
-> HsParsedModule -> IO (TcGblEnv, Maybe RenamedSource)
forall a b. (a -> b) -> a -> b
$
                       HsParsedModule :: ParsedSource -> [String] -> ApiAnns -> HsParsedModule
HsParsedModule { hpm_module :: ParsedSource
hpm_module = ParsedModule -> ParsedSource
forall m. ParsedMod m => m -> ParsedSource
parsedSource ParsedModule
pmod,
                                        hpm_src_files :: [String]
hpm_src_files = ParsedModule -> [String]
pm_extra_src_files ParsedModule
pmod,
                                        hpm_annotations :: ApiAnns
hpm_annotations = ParsedModule -> ApiAnns
pm_annotations ParsedModule
pmod }
  TypecheckedModule -> m TypecheckedModule
forall (m :: * -> *) a. Monad m => a -> m a
return TypecheckedModule :: ParsedModule
-> Maybe RenamedSource
-> ModSummary
-> TcGblEnv
-> TypecheckedModule
TypecheckedModule {
      tm_parsed_module :: ParsedModule
tm_parsed_module  = ParsedModule
pmod
    , tm_renamed_source :: Maybe RenamedSource
tm_renamed_source = Maybe RenamedSource
rn_info
    , tm_mod_summary :: ModSummary
tm_mod_summary    = ModSummary
ms
    , tm_gbl_env :: TcGblEnv
tm_gbl_env        = TcGblEnv
tc_gbl_env
    }

{- | [NOTE:ghc810]
Something changed in the GHC bowels such that the 'hscTarget' that the 'ModSummary' was inheriting
was /not/ the one we were setting in 'configureDynFlags'. This is important, because if the 'hscTarget'
is not 'HscInterpreted' or 'HscNothing', the call to 'targetRetainsAllBindings' will yield 'False'. This
function is used internally by GHC to do dead-code-elimination and to mark functions as "exported" or not.
Therefore, the 'CoreBind's passed to LiquidHaskell would be different between GHC 8.6.5 and GHC 8.10.
-}

class IsTypecheckedModule t where
  tmParsedModule :: Lens'  t ParsedModule
  tmModSummary   :: Lens'  t ModSummary
  tmGblEnv       :: Getter t TcGblEnv

instance IsTypecheckedModule TypecheckedModule where
  tmParsedModule :: Lens' TypecheckedModule ParsedModule
tmParsedModule = (TypecheckedModule -> ParsedModule)
-> (TypecheckedModule -> ParsedModule -> TypecheckedModule)
-> Lens' TypecheckedModule ParsedModule
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens TypecheckedModule -> ParsedModule
tm_parsed_module (\TypecheckedModule
s ParsedModule
x -> TypecheckedModule
s { tm_parsed_module :: ParsedModule
tm_parsed_module = ParsedModule
x })
  tmModSummary :: Lens' TypecheckedModule ModSummary
tmModSummary   = (TypecheckedModule -> ModSummary)
-> (TypecheckedModule -> ModSummary -> TypecheckedModule)
-> Lens' TypecheckedModule ModSummary
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens TypecheckedModule -> ModSummary
tm_mod_summary   (\TypecheckedModule
s ModSummary
x -> TypecheckedModule
s { tm_mod_summary :: ModSummary
tm_mod_summary = ModSummary
x })
  tmGblEnv :: Getter TypecheckedModule TcGblEnv
tmGblEnv       = (TypecheckedModule -> TcGblEnv)
-> Getter TypecheckedModule TcGblEnv
forall s a. (s -> a) -> Getter s a
to TypecheckedModule -> TcGblEnv
tm_gbl_env

instance IsTypecheckedModule Ghc.TypecheckedModule where
  tmParsedModule :: Lens' TypecheckedModule ParsedModule
tmParsedModule = (TypecheckedModule -> ParsedModule)
-> (TypecheckedModule -> ParsedModule -> TypecheckedModule)
-> Lens' TypecheckedModule ParsedModule
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens TypecheckedModule -> ParsedModule
Ghc.tm_parsed_module (\TypecheckedModule
s ParsedModule
x -> TypecheckedModule
s { tm_parsed_module :: ParsedModule
Ghc.tm_parsed_module = ParsedModule
x })
  tmModSummary :: Lens' TypecheckedModule ModSummary
tmModSummary   = (TypecheckedModule -> ModSummary)
-> (TypecheckedModule -> ModSummary -> TypecheckedModule)
-> Lens' TypecheckedModule ModSummary
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (ParsedModule -> ModSummary
pm_mod_summary (ParsedModule -> ModSummary)
-> (TypecheckedModule -> ParsedModule)
-> TypecheckedModule
-> ModSummary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypecheckedModule -> ParsedModule
Ghc.tm_parsed_module)
                        (\TypecheckedModule
s ModSummary
x -> Lens' TypecheckedModule ParsedModule
-> (ParsedModule -> ParsedModule)
-> TypecheckedModule
-> TypecheckedModule
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Lens' TypecheckedModule ParsedModule
forall t. IsTypecheckedModule t => Lens' t ParsedModule
tmParsedModule (\ParsedModule
pm -> ParsedModule
pm { pm_mod_summary :: ModSummary
Ghc.pm_mod_summary = ModSummary
x }) TypecheckedModule
s )
  tmGblEnv :: Getter TypecheckedModule TcGblEnv
tmGblEnv       = (TypecheckedModule -> TcGblEnv)
-> Getter TypecheckedModule TcGblEnv
forall s a. (s -> a) -> Getter s a
to ((TcGblEnv, ModDetails) -> TcGblEnv
forall a b. (a, b) -> a
fst ((TcGblEnv, ModDetails) -> TcGblEnv)
-> (TypecheckedModule -> (TcGblEnv, ModDetails))
-> TypecheckedModule
-> TcGblEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypecheckedModule -> (TcGblEnv, ModDetails)
Ghc.tm_internals_)

-- | Desugar a typechecked module.
desugarModule :: (GhcMonadLike m, IsTypecheckedModule t) => ModSummary -> t -> m ModGuts
desugarModule :: ModSummary -> t -> m ModGuts
desugarModule ModSummary
originalModSum t
typechecked = do
  -- See [NOTE:ghc810] on why we override the dynFlags here before calling 'desugarModule'.
  DynFlags
dynFlags          <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  let modSum :: ModSummary
modSum         = ModSummary
originalModSum { ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags
dynFlags }
  let parsedMod' :: ParsedModule
parsedMod'     = (Optic' A_Lens NoIx t ParsedModule -> t -> ParsedModule
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx t ParsedModule
forall t. IsTypecheckedModule t => Lens' t ParsedModule
tmParsedModule t
typechecked) { pm_mod_summary :: ModSummary
pm_mod_summary = ModSummary
modSum }
  let typechecked' :: t
typechecked'   = Optic' A_Lens NoIx t ParsedModule -> ParsedModule -> t -> t
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set Optic' A_Lens NoIx t ParsedModule
forall t. IsTypecheckedModule t => Lens' t ParsedModule
tmParsedModule ParsedModule
parsedMod' t
typechecked

  HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). HasHscEnv m => m HscEnv
askHscEnv
  let hsc_env_tmp :: HscEnv
hsc_env_tmp = HscEnv
hsc_env { hsc_dflags :: DynFlags
hsc_dflags = ModSummary -> DynFlags
ms_hspp_opts (Optic' A_Lens NoIx t ModSummary -> t -> ModSummary
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx t ModSummary
forall t. IsTypecheckedModule t => Lens' t ModSummary
tmModSummary t
typechecked') }
  IO ModGuts -> m ModGuts
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModGuts -> m ModGuts) -> IO ModGuts -> m ModGuts
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
hscDesugar HscEnv
hsc_env_tmp (Optic' A_Lens NoIx t ModSummary -> t -> ModSummary
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx t ModSummary
forall t. IsTypecheckedModule t => Lens' t ModSummary
tmModSummary t
typechecked') (Optic' A_Getter NoIx t TcGblEnv -> t -> TcGblEnv
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Getter NoIx t TcGblEnv
forall t. IsTypecheckedModule t => Getter t TcGblEnv
tmGblEnv t
typechecked')

-- | Takes a 'ModuleName' and possibly a 'UnitId', and consults the
-- filesystem and package database to find the corresponding 'Module',
-- using the algorithm that is used for an @import@ declaration.
findModule :: GhcMonadLike m => ModuleName -> Maybe FastString -> m Module
findModule :: ModuleName -> Maybe FastString -> m Module
findModule ModuleName
mod_name Maybe FastString
maybe_pkg = do
  HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). HasHscEnv m => m HscEnv
askHscEnv
  let
    dflags :: DynFlags
dflags   = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    this_pkg :: UnitId
this_pkg = DynFlags -> UnitId
thisPackage DynFlags
dflags
  --
  case Maybe FastString
maybe_pkg of
    Just FastString
pkg | FastString -> UnitId
fsToUnitId FastString
pkg UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
/= UnitId
this_pkg Bool -> Bool -> Bool
&& FastString
pkg FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> FastString
fsLit String
"this" -> IO Module -> m Module
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Module -> m Module) -> IO Module -> m Module
forall a b. (a -> b) -> a -> b
$ do
      FindResult
res <- HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
mod_name Maybe FastString
maybe_pkg
      case FindResult
res of
        Found ModLocation
_ Module
m -> Module -> IO Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
        FindResult
err       -> ErrMsg -> IO Module
forall (io :: * -> *) a. MonadIO io => ErrMsg -> io a
throwOneError (ErrMsg -> IO Module) -> ErrMsg -> IO Module
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> ModuleName -> FindResult -> ErrMsg
noModError DynFlags
dflags SrcSpan
noSrcSpan ModuleName
mod_name FindResult
err
    Maybe FastString
_otherwise -> do
      Maybe Module
home <- ModuleName -> m (Maybe Module)
forall (m :: * -> *).
GhcMonadLike m =>
ModuleName -> m (Maybe Module)
lookupLoadedHomeModule ModuleName
mod_name
      case Maybe Module
home of
        Just Module
m  -> Module -> m Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
        Maybe Module
Nothing -> IO Module -> m Module
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Module -> m Module) -> IO Module -> m Module
forall a b. (a -> b) -> a -> b
$ do
           FindResult
res <- HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
mod_name Maybe FastString
maybe_pkg
           case FindResult
res of
             Found ModLocation
loc Module
m | Module -> UnitId
moduleUnitId Module
m UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
/= UnitId
this_pkg -> Module -> IO Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
                         | Bool
otherwise -> DynFlags -> Module -> ModLocation -> IO Module
forall a. DynFlags -> Module -> ModLocation -> IO a
modNotLoadedError DynFlags
dflags Module
m ModLocation
loc
             FindResult
err -> ErrMsg -> IO Module
forall (io :: * -> *) a. MonadIO io => ErrMsg -> io a
throwOneError (ErrMsg -> IO Module) -> ErrMsg -> IO Module
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> ModuleName -> FindResult -> ErrMsg
noModError DynFlags
dflags SrcSpan
noSrcSpan ModuleName
mod_name FindResult
err


lookupLoadedHomeModule :: GhcMonadLike m => ModuleName -> m (Maybe Module)
lookupLoadedHomeModule :: ModuleName -> m (Maybe Module)
lookupLoadedHomeModule ModuleName
mod_name = do
  HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). HasHscEnv m => m HscEnv
askHscEnv
  case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) ModuleName
mod_name of
    Just HomeModInfo
mod_info      -> Maybe Module -> m (Maybe Module)
forall (m :: * -> *) a. Monad m => a -> m a
return (Module -> Maybe Module
forall a. a -> Maybe a
Just (ModIface_ 'ModIfaceFinal -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (HomeModInfo -> ModIface_ 'ModIfaceFinal
hm_iface HomeModInfo
mod_info)))
    Maybe HomeModInfo
_not_a_home_module -> Maybe Module -> m (Maybe Module)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Module
forall a. Maybe a
Nothing


modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a
modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a
modNotLoadedError DynFlags
dflags Module
m ModLocation
loc = GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO a) -> GhcException -> IO a
forall a b. (a -> b) -> a -> b
$ String -> GhcException
CmdLineError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$
   String -> SDoc
text String
"module is not loaded:" SDoc -> SDoc -> SDoc
<+>
   SDoc -> SDoc
quotes (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> ModuleName
moduleName Module
m)) SDoc -> SDoc -> SDoc
<+>
   SDoc -> SDoc
parens (String -> SDoc
text (String -> Maybe String -> String
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"modNotLoadedError" (ModLocation -> Maybe String
ml_hs_file ModLocation
loc)))


lookupModule :: GhcMonadLike m => ModuleName -> Maybe FastString -> m Module
lookupModule :: ModuleName -> Maybe FastString -> m Module
lookupModule ModuleName
mod_name (Just FastString
pkg) = ModuleName -> Maybe FastString -> m Module
forall (m :: * -> *).
GhcMonadLike m =>
ModuleName -> Maybe FastString -> m Module
findModule ModuleName
mod_name (FastString -> Maybe FastString
forall a. a -> Maybe a
Just FastString
pkg)
lookupModule ModuleName
mod_name Maybe FastString
Nothing = do
  HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). HasHscEnv m => m HscEnv
askHscEnv
  Maybe Module
home <- ModuleName -> m (Maybe Module)
forall (m :: * -> *).
GhcMonadLike m =>
ModuleName -> m (Maybe Module)
lookupLoadedHomeModule ModuleName
mod_name
  case Maybe Module
home of
    Just Module
m  -> Module -> m Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
    Maybe Module
Nothing -> IO Module -> m Module
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Module -> m Module) -> IO Module -> m Module
forall a b. (a -> b) -> a -> b
$ do
      FindResult
res <- HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
findExposedPackageModule HscEnv
hsc_env ModuleName
mod_name Maybe FastString
forall a. Maybe a
Nothing
      case FindResult
res of
        Found ModLocation
_ Module
m -> Module -> IO Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
        FindResult
err       -> ErrMsg -> IO Module
forall (io :: * -> *) a. MonadIO io => ErrMsg -> io a
throwOneError (ErrMsg -> IO Module) -> ErrMsg -> IO Module
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> ModuleName -> FindResult -> ErrMsg
noModError (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) SrcSpan
noSrcSpan ModuleName
mod_name FindResult
err