Delete redundant code (#1199)

src/Development/IDE/Functions/Compile.hs

@@ -45,8 +45,6 @@ import           MkIface
 import           NameCache
 import           StringBuffer                   as SB
 import           TidyPgm
-import           InstEnv
-import           FamInstEnv
 import qualified GHC.LanguageExtensions as LangExt
 
 import Control.DeepSeq
@@ -139,16 +137,14 @@ typecheckModule
     :: IdeOptions
     -> ParsedModule
     -> HscEnv
-    -> UniqSupply
     -> [TcModuleResult]
-    -> [LoadPackageResult]
     -> ParsedModule
     -> IO ([FileDiagnostic], Maybe TcModuleResult)
-typecheckModule opt mod packageState uniqSupply deps pkgs pm =
+typecheckModule opt mod packageState deps pm =
     fmap (either (, Nothing) (second Just)) $ Ex.runExceptT $
     runGhcSessionExcept opt (Just mod) packageState $
         catchSrcErrors $ do
-            setupEnv uniqSupply deps pkgs
+            setupEnv deps
             (warnings, tcm) <- withWarnings "Typechecker" $ \tweak ->
                 GHC.typecheckModule pm{pm_mod_summary = tweak $ pm_mod_summary pm}
             tcm2 <- mkTcModuleResult (WriteInterface $ optWriteIface opt) tcm
@@ -158,23 +154,13 @@ typecheckModule opt mod packageState uniqSupply deps pkgs pm =
 loadPackage ::
      IdeOptions
   -> HscEnv
-  -> UniqSupply
-  -> [LoadPackageResult]
   -> InstalledUnitId
   -> IO (Either [FileDiagnostic] LoadPackageResult)
-loadPackage opt packageState us lps p =
+loadPackage opt packageState p =
   Ex.runExceptT $
   runGhcSessionExcept opt Nothing packageState $
   catchSrcErrors $ do
-    setupEnv us [] lps
-    dflags <- hsc_dflags <$> getSession
-    exposedMods <- liftIO $ exposedModules <$> getPackage dflags p
-    let mods =
-          [ Module (DefiniteUnitId (DefUnitId p)) mod
-          | (mod, _mbParent) <- exposedMods
-          , False {- HLINT ignore "Short-circuited list comprehension" -}
-          ]
-    forM_ mods $ \mod -> GHC.getModuleInfo mod
+    setupEnv []
     -- this populates the namecache and external package state
     session <- getSession
     modEnv <- nsNames <$> liftIO (readIORef $ hsc_NC session)
@@ -187,16 +173,14 @@ compileModule
     :: IdeOptions
     -> ParsedModule
     -> HscEnv
-    -> UniqSupply
     -> [TcModuleResult]
-    -> [LoadPackageResult]
     -> TcModuleResult
     -> IO ([FileDiagnostic], Maybe GhcModule)
-compileModule opt mod packageState uniqSupply deps pkgs tmr =
+compileModule opt mod packageState deps tmr =
     fmap (either (, Nothing) (second Just)) $ Ex.runExceptT $
     runGhcSessionExcept opt (Just mod) packageState $
         catchSrcErrors $ do
-            setupEnv uniqSupply (deps ++ [tmr]) pkgs
+            setupEnv (deps ++ [tmr])
 
             let tm = tmrModule tmr
             session <- getSession
@@ -259,29 +243,6 @@ moduleImportPaths pm
     rootModDir   = takeDirectory . moduleNameSlashes . GHC.moduleName $ mod'
 
 
--- When we make a fresh GHC environment, the OrigNameCache comes already partially
--- populated. So to be safe, we simply extend this one.
-mkNameCache :: GhcMonad m => UniqSupply -> [TcModuleResult] -> [LoadPackageResult] -> m NameCache
-mkNameCache uniqSupply tms pkgs = do
-    session    <- getSession
-    onc        <- nsNames <$> liftIO (readIORef $ hsc_NC session)
-    return NameCache
-            { nsUniqs = uniqSupply
-            , nsNames = extendOrigNameCache' onc tms pkgs
-            }
-
--- | Extend the name cache with the names from the typechecked home modules and the loaded packages.
--- If we have two environments containing the same module we take the later one. We do this because
--- the name cache comes prepopulated with modules from daml-prim and we overwrite those with our own
--- daml-prim package.
-extendOrigNameCache' :: OrigNameCache -> [TcModuleResult] -> [LoadPackageResult] -> OrigNameCache
-extendOrigNameCache' onc tms pkgs = foldl (plusModuleEnv_C (\_x y -> y)) onc modEnvs
-  where
-    modEnvs =
-      mkModuleEnv
-         [(ms_mod $ tcModSummary $ tmrModule tm, tmrOccEnvName tm) | tm <- tms] :
-      [lprModuleEnv lm | lm <- pkgs]
-
 newtype WriteInterface = WriteInterface Bool
 
 mkTcModuleResult
@@ -319,8 +280,8 @@ tcModSummary = pm_mod_summary . tm_parsed_module
 
 -- | Setup the environment that GHC needs according to our
 -- best understanding (!)
-setupEnv :: GhcMonad m => UniqSupply -> [TcModuleResult] -> [LoadPackageResult] -> m ()
-setupEnv uniqSupply tms lps = do
+setupEnv :: GhcMonad m => [TcModuleResult] -> m ()
+setupEnv tms = do
     session <- getSession
 
     let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms
@@ -337,64 +298,9 @@ setupEnv uniqSupply tms lps = do
         foldl' (\fc (im, ifr) -> GHC.extendInstalledModuleEnv fc im ifr) fc
             $ zip ims ifrs
 
-    when False $ do
-        -- construct a new NameCache
-        nc' <- mkNameCache uniqSupply tms lps
-        -- update the name cache
-        liftIO $ modifyIORef (hsc_NC session) $ const nc'
-        -- update the external package state
-        liftIO $ modifyIORef (hsc_EPS session) (updateEps lps)
     -- load dependent modules, which must be in topological order.
     mapM_ loadModuleHome tms
 
--- | Update the external package state given the loaded package results.
-updateEps :: [LoadPackageResult] -> ExternalPackageState -> ExternalPackageState
-updateEps lps eps =
-  eps
-    { eps_inst_env = newInstEnv
-    , eps_PIT = newPIT
-    , eps_PTE = newPTE
-    , eps_rule_base = newRuleBase
-    , eps_complete_matches = newCompleteMatches
-    , eps_fam_inst_env = newFamInst
-    , eps_ann_env = newAnnEnv
-    , eps_mod_fam_inst_env = newModFamInstEnv
-    }
-  where
-    (newInstEnv, (newPIT, (newPTE, (newRuleBase, (newCompleteMatches, (newFamInst, (newAnnEnv, newModFamInstEnv))))))) =
-      foldl
-        (\(instEnv, (pit, (pte, (ruleBase, (completeMatches, (famInst, (annEnv, modFamInstEnv))))))) ->
-           (instEnv `extendInstEnvList0`) ***
-           (pit `plusModuleEnv`) ***
-           (pte `plusTypeEnv`) ***
-           (ruleBase `unionRuleBase`) ***
-           (completeMatches `extendCompleteMatchMap`) ***
-           (famInst `extendFamInstEnvList`) ***
-           (annEnv `plusAnnEnv`) *** (modFamInstEnv `plusModuleEnv`))
-        ( emptyInstEnv
-        , ( emptyPackageIfaceTable
-          , ( emptyTypeEnv
-            , ( emptyRuleBase
-              , (emptyUFM, (emptyFamInstEnv, (emptyAnnEnv, emptyModuleEnv)))))))
-        [ ( instEnvElts $ eps_inst_env e
-          , ( eps_PIT e
-            , ( eps_PTE e
-              , ( eps_rule_base e
-                , ( concat $ eltsUFM $ eps_complete_matches e
-                  , ( famInstEnvElts $ eps_fam_inst_env e
-                    , (eps_ann_env e, eps_mod_fam_inst_env e)))))))
-        | p <- lps
-        , let e = lprEps p
-        ]
-
-    -- TODO (drsk): This is necessary because the EPS that we store include the results of
-    -- previously loaded packages and we end up adding instances several times to the environment.
-    -- It would be better to have pure delta stored in the LoadPackageResult, such that it
-    -- contains only identities/instances/names coming from that specific loaded package, but I
-    -- failed so far in computing the correct delta.
-    extendInstEnvList0 instEnv0 clsInsts =
-      extendInstEnvList emptyInstEnv $
-      nubOrdOn is_dfun_name $ instEnvElts instEnv0 ++ clsInsts
 
 -- | Load a module, quickly. Input doesn't need to be desugared.
 -- A module must be loaded before dependent modules can be typechecked.

src/Development/IDE/State/RuleTypes.hs

@@ -51,9 +51,6 @@ type instance RuleResult GetDependencies = TransitiveDependencies
 -- | The type checked version of this file, requires TypeCheck+
 type instance RuleResult TypeCheck = TcModuleResult
 
--- | The result of loading a module from a package.
-type instance RuleResult LoadPackage = LoadPackageResult
-
 -- | Information about what spans occur where, requires TypeCheck
 type instance RuleResult GetSpanInfo = [SpanInfo]
 
@@ -111,11 +108,6 @@ data TypeCheck = TypeCheck
 instance Hashable TypeCheck
 instance NFData   TypeCheck
 
-data LoadPackage = LoadPackage InstalledUnitId
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable LoadPackage
-instance NFData   LoadPackage
-
 data GetSpanInfo = GetSpanInfo
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable GetSpanInfo

src/Development/IDE/State/Rules.hs

@@ -23,8 +23,6 @@ module Development.IDE.State.Rules(
     fileFromParsedModule
     ) where
 
-import           Control.Concurrent.Extra
-import Control.Exception (evaluate)
 import           Control.Monad.Except
 import Control.Monad.Extra (whenJust)
 import qualified Development.IDE.Functions.Compile             as Compile
@@ -73,16 +71,6 @@ defineNoFile f = define $ \k file -> do
         fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"
 
 
--- | Return a distinct supply of uniques.
-getUniqSupply :: Action UniqSupply
-getUniqSupply =
-    getServiceEnv >>= liftIO . getUniqSupplyFrom
-
-getUniqSupplyFrom :: Env -> IO UniqSupply
-getUniqSupplyFrom Env{..} =
-    modifyVar envUniqSupplyVar $ evaluate . splitUniqSupply
-
-
 ------------------------------------------------------------
 -- Exposed API
 
@@ -290,45 +278,23 @@ typeCheckRule =
     define $ \TypeCheck file -> do
         pm <- use_ GetParsedModule file
         deps <- use_ GetDependencies file
-        lps <- mapM (flip use_ "" . LoadPackage) (transitivePkgDeps deps)
         tms <- uses_ TypeCheck (transitiveModuleDeps deps)
         setPriority PriorityTypeCheck
-        us <- getUniqSupply
         packageState <- use_ GhcSession ""
         opt <- getOpts
-        liftIO $ Compile.typecheckModule opt pm packageState us tms lps pm
-
-
-loadPackageRule :: Rules ()
-loadPackageRule =
-  defineNoFile $ \(LoadPackage pkg) -> do
-      packageState <- use_ GhcSession ""
-      opt <- getOpts
-      pkgs <- liftIO $ Compile.computePackageDeps opt packageState pkg
-      case pkgs of
-        Left e -> do
-            reportSeriousErrorDie $ "LoadPackage " ++ show pkg ++ " computePackageDeps failed, " ++ show e
-        Right v -> do
-            lps <- mapM (flip use_ "" . LoadPackage) v
-            us <- getUniqSupply
-            res <- liftIO $ Compile.loadPackage opt packageState us lps pkg
-            case res of
-                Left e -> reportSeriousErrorDie $ "LoadPackage " ++ show pkg ++ " loadPackage failed, " ++ show e
-                Right v -> return v
+        liftIO $ Compile.typecheckModule opt pm packageState tms pm
 
 
 generateCoreRule :: Rules ()
 generateCoreRule =
     define $ \GenerateCore file -> do
         deps <- use_ GetDependencies file
-        lps <- mapM (flip use_ "" . LoadPackage) (transitivePkgDeps deps)
         (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)
         let pm = tm_parsed_module . Compile.tmrModule $ tm
         setPriority PriorityGenerateDalf
-        us <- getUniqSupply
         packageState <- use_ GhcSession ""
         opt <- getOpts
-        liftIO $ Compile.compileModule opt pm packageState us tms lps tm
+        liftIO $ Compile.compileModule opt pm packageState tms tm
 
 loadGhcSession :: Rules ()
 loadGhcSession =
@@ -359,7 +325,6 @@ mainRule = do
     getSpanInfoRule
     generateCoreRule
     loadGhcSession
-    loadPackageRule
     getHieFileRule
 
 ------------------------------------------------------------