-- | Dynamically lookup up values from modules and loading them.
module DynamicLoading (
#ifdef GHCI
        -- * Force loading information
        forceLoadModuleInterfaces,
        forceLoadNameModuleInterface,
        forceLoadTyCon,
        
        -- * Finding names
        lookupRdrNameInModule,
        
        -- * Loading values
        getValueSafely,
        lessUnsafeCoerce
#endif
    ) where

#ifdef GHCI
import Linker           ( linkModule, getHValue, lessUnsafeCoerce )
import OccName          ( occNameSpace )
import Name             ( nameOccName )
import SrcLoc           ( noSrcSpan )
import Finder           ( findImportedModule, cannotFindModule )
import DriverPhases     ( HscSource(HsSrcFile) )
import TcRnDriver       ( getModuleExports )
import TcRnMonad        ( initTc, initIfaceTcRn )
import LoadIface        ( loadUserInterface )
import RdrName          ( RdrName, Provenance(..), ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), 
                          mkGlobalRdrEnv, lookupGRE_RdrName, gre_name, rdrNameSpace )
import RnNames          ( gresFromAvails )
import PrelNames        ( iNTERACTIVE )

import HscTypes         ( HscEnv(..), FindResult(..), lookupTypeHscEnv )
import TypeRep          ( TyThing(..), pprTyThingCategory )
import Type             ( Type, eqType )
import TyCon            ( TyCon )
import Name             ( Name, nameModule_maybe )
import Id               ( idType )
import Module           ( Module, ModuleName )
import Panic            ( GhcException(..), throwGhcException )
import FastString
import Outputable

import Data.Maybe        ( mapMaybe )


-- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used
-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded.
forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO ()
forceLoadModuleInterfaces hsc_env doc modules
    = (initTc hsc_env HsSrcFile False iNTERACTIVE $ initIfaceTcRn $ mapM_ (loadUserInterface False doc) modules) >> return ()

-- | Force the interface for the module containing the name to be loaded. The 'SDoc' parameter is used
-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded.
forceLoadNameModuleInterface :: HscEnv -> SDoc -> Name -> IO ()
forceLoadNameModuleInterface hsc_env reason name = do
    let name_modules = mapMaybe nameModule_maybe [name]
    forceLoadModuleInterfaces hsc_env reason name_modules

-- | Load the 'TyCon' associated with the given name, come hell or high water. Fails if:
--
-- * The interface could not be loaded
-- * The name is not that of a 'TyCon'
-- * The name did not exist in the loaded module
forceLoadTyCon :: HscEnv -> Name -> IO TyCon
forceLoadTyCon hsc_env con_name = do
    forceLoadNameModuleInterface hsc_env (ptext (sLit "contains a name used in an invocation of loadTyConTy")) con_name
    
    mb_con_thing <- lookupTypeHscEnv hsc_env con_name
    case mb_con_thing of
        Nothing -> throwCmdLineErrorS $ missingTyThingError con_name
        Just (ATyCon tycon) -> return tycon
        Just con_thing -> throwCmdLineErrorS $ wrongTyThingError con_name con_thing

-- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety
-- in that it is up to the user to ensure that that type corresponds to the type you try to use the return value at!
--
-- If the value found was not of the correct type, returns @Nothing@. Any other condition results in an exception:
--
-- * If we could not load the names module
-- * If the thing being loaded is not a value
-- * If the Name does not exist in the module
-- * If the link failed

getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a)
getValueSafely hsc_env val_name expected_type = do
    forceLoadNameModuleInterface hsc_env (ptext (sLit "contains a name used in an invocation of getValueSafely")) val_name
    
    -- Now look up the names for the value and type constructor in the type environment
    mb_val_thing <- lookupTypeHscEnv hsc_env val_name
    case mb_val_thing of
        Nothing -> throwCmdLineErrorS $ missingTyThingError val_name
        Just (AnId id) -> do
            -- Check the value type in the interface against the type recovered from the type constructor
            -- before finally casting the value to the type we assume corresponds to that constructor
            if expected_type `eqType` idType id
             then do
                -- Link in the module that contains the value, if it has such a module
                case nameModule_maybe val_name of
                    Just mod -> do linkModule hsc_env mod
                                   return ()
                    Nothing ->  return ()
                -- Find the value that we just linked in and cast it given that we have proved it's type
                hval <- getHValue hsc_env val_name
                value <- lessUnsafeCoerce (hsc_dflags hsc_env) "getValueSafely" hval
                return $ Just value
             else return Nothing
        Just val_thing -> throwCmdLineErrorS $ wrongTyThingError val_name val_thing

-- | Finds the 'Name' corresponding to the given 'RdrName' in the context of the 'ModuleName'. Returns @Nothing@ if no
-- such 'Name' could be found. Any other condition results in an exception:
--
-- * If the module could not be found
-- * If we could not determine the imports of the module
lookupRdrNameInModule :: HscEnv -> ModuleName -> RdrName -> IO (Maybe Name)
lookupRdrNameInModule hsc_env mod_name rdr_name = do
    -- First find the package the module resides in by searching exposed packages and home modules
    found_module <- findImportedModule hsc_env mod_name Nothing
    case found_module of
        Found _ mod -> do
            -- Find the exports of the module
            (_, mb_avail_info) <- getModuleExports hsc_env mod
            case mb_avail_info of
                Just avail_info -> do
                    -- Try and find the required name in the exports
                    let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, is_qual = False, is_dloc = noSrcSpan }
                        provenance = Imported [ImpSpec decl_spec ImpAll]
                        env = mkGlobalRdrEnv (gresFromAvails provenance avail_info)
                    case [name | gre <- lookupGRE_RdrName rdr_name env, let name = gre_name gre, rdrNameSpace rdr_name == occNameSpace (nameOccName name)] of
                        [name] -> return (Just name)
                        []     -> return Nothing
                        _      -> panic "lookupRdrNameInModule"
                Nothing -> throwCmdLineErrorS $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name]
        err -> throwCmdLineErrorS $ cannotFindModule dflags mod_name err
  where
    dflags = hsc_dflags hsc_env


wrongTyThingError :: Name -> TyThing -> SDoc
wrongTyThingError name got_thing = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not that of a value but rather a"), pprTyThingCategory got_thing]

missingTyThingError :: Name -> SDoc
missingTyThingError name = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")]

throwCmdLineErrorS :: SDoc -> IO a
throwCmdLineErrorS = throwCmdLineError . showSDoc

throwCmdLineError :: String -> IO a
throwCmdLineError = throwGhcException . CmdLineError
#endif