Merge pull request #24 from ndmitchell/multienv

Add multi environment support

Author: cocreature

exe/Main.hs

@@ -23,6 +23,7 @@ import Development.IDE.Types.Location
 import Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Options
 import Development.IDE.Types.Logger
+import Development.IDE.GHC.Util
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import Language.Haskell.LSP.Messages
@@ -36,9 +37,6 @@ import System.IO
 import Development.Shake hiding (Env)
 import qualified Data.Set as Set
 
--- import CmdLineParser
--- import DynFlags
--- import Panic
 import GHC hiding (def)
 import qualified GHC.Paths
 
@@ -71,10 +69,12 @@ main = do
         runLanguageServer def def $ \event vfs caps -> do
             t <- t
             hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
-            let options = (defaultIdeOptions $ liftIO $ newSession' =<< findCradle (dir <> "/"))
+            let options = (defaultIdeOptions $ loadEnvironment dir)
                     { optReportProgress = clientSupportsProgress caps }
             initialise (mainRule >> action kick) event logger options vfs
     else do
+        -- Note that this whole section needs to change once we have genuine
+        -- multi environment support. Needs rewriting in terms of loadEnvironment.
         putStrLn "[1/6] Finding hie-bios cradle"
         cradle <- findCradle (dir <> "/")
         print cradle
@@ -84,7 +84,7 @@ main = do
 
         putStrLn "\n[3/6] Initialising IDE session"
         vfs <- makeVFSHandle
-        ide <- initialise mainRule (showEvent lock) logger (defaultIdeOptions $ return env) vfs
+        ide <- initialise mainRule (showEvent lock) logger (defaultIdeOptions $ return $ const $ return env) vfs
 
         putStrLn "\n[4/6] Finding interesting files"
         files <- nubOrd <$> expandFiles (argFiles ++ ["." | null argFiles])
@@ -128,10 +128,15 @@ showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =
     withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,) diags
 showEvent lock e = withLock lock $ print e
 
-newSession' :: Cradle -> IO HscEnv
+newSession' :: Cradle -> IO HscEnvEq
 newSession' cradle = getLibdir >>= \libdir -> do
     env <- runGhc (Just libdir) $ do
         initializeFlagsWithCradle "" cradle
         getSession
     initDynLinker env
-    pure env
+    newHscEnvEq env
+
+loadEnvironment :: FilePath -> IO (FilePath -> Action HscEnvEq)
+loadEnvironment dir = do
+    res <- liftIO $ newSession' =<< findCradle (dir <> "/")
+    return $ const $ return res

src/Development/IDE/Core/RuleTypes.hs

@@ -13,6 +13,7 @@ module Development.IDE.Core.RuleTypes(
 
 import           Control.DeepSeq
 import           Development.IDE.Import.DependencyInformation
+import Development.IDE.GHC.Util
 import Development.IDE.Types.Location
 import           Data.Hashable
 import           Data.Typeable
@@ -66,7 +67,7 @@ type instance RuleResult GetSpanInfo = [SpanInfo]
 type instance RuleResult GenerateCore = CoreModule
 
 -- | A GHC session that we reuse.
-type instance RuleResult GhcSession = HscEnv
+type instance RuleResult GhcSession = HscEnvEq
 
 -- | Resolve the imports in a module to the file path of a module
 -- in the same package or the package id of another package.

src/Development/IDE/Core/Rules.hs

@@ -36,6 +36,7 @@ import Development.IDE.Import.FindImports
 import           Development.IDE.Core.FileStore
 import           Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Location
+import Development.IDE.GHC.Util
 import Data.Coerce
 import Data.Either.Extra
 import Data.Maybe
@@ -54,10 +55,12 @@ import Development.IDE.GHC.Compat
 import           UniqSupply
 import NameCache
 import HscTypes
+import GHC.Generics(Generic)
 
 import qualified Development.IDE.Spans.AtPoint as AtPoint
 import Development.IDE.Core.Service
 import Development.IDE.Core.Shake
+import Development.Shake.Classes
 import System.Directory
 import System.FilePath
 import MkIface
@@ -116,7 +119,7 @@ getAtPoint file pos = fmap join $ runMaybeT $ do
 getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)
 getDefinition file pos = fmap join $ runMaybeT $ do
     spans <- useE GetSpanInfo file
-    pkgState <- useNoFileE GhcSession
+    pkgState <- hscEnv <$> useE GhcSession file
     opts <- lift getIdeOptions
     let getHieFile x = useNoFile (GetHieFile x)
     lift $ AtPoint.gotoDefinition getHieFile opts pkgState spans pos
@@ -131,8 +134,9 @@ writeIfacesAndHie ::
 writeIfacesAndHie ifDir files =
     runMaybeT $ do
         tcms <- usesE TypeCheck files
-        session <- lift $ useNoFile_ GhcSession
-        liftIO $ concat <$> mapM (writeTcm session) tcms
+        fmap concat $ forM (zip files tcms) $ \(file, tcm) -> do
+            session <- lift $ hscEnv <$> use_ GhcSession file
+            liftIO $ writeTcm session tcm
   where
     writeTcm session tcm =
         do
@@ -174,7 +178,7 @@ getParsedModuleRule :: Rules ()
 getParsedModuleRule =
     define $ \GetParsedModule file -> do
         (_, contents) <- getFileContents file
-        packageState <- useNoFile_ GhcSession
+        packageState <- hscEnv <$> use_ GhcSession file
         opt <- getIdeOptions
         liftIO $ parseModule opt packageState (fromNormalizedFilePath file) contents
 
@@ -184,7 +188,7 @@ getLocatedImportsRule =
         pm <- use_ GetParsedModule file
         let ms = pm_mod_summary pm
         let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]
-        env <- useNoFile_ GhcSession
+        env <- hscEnv <$> useNoFile_ GhcSession
         let dflags = addRelativeImport pm $ hsc_dflags env
         opt <- getIdeOptions
         (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do
@@ -295,7 +299,7 @@ getSpanInfoRule =
     define $ \GetSpanInfo file -> do
         tc <- use_ TypeCheck file
         (fileImports, _) <- use_ GetLocatedImports file
-        packageState <- useNoFile_ GhcSession
+        packageState <- hscEnv <$> use_ GhcSession file
         x <- liftIO $ getSrcSpanInfos packageState fileImports tc
         return ([], Just x)
 
@@ -307,7 +311,7 @@ typeCheckRule =
         deps <- use_ GetDependencies file
         tms <- uses_ TypeCheck (transitiveModuleDeps deps)
         setPriority priorityTypeCheck
-        packageState <- useNoFile_ GhcSession
+        packageState <- hscEnv <$> use_ GhcSession file
         liftIO $ typecheckModule packageState tms pm
 
 
@@ -317,14 +321,33 @@ generateCoreRule =
         deps <- use_ GetDependencies file
         (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)
         setPriority priorityGenerateCore
-        packageState <- useNoFile_ GhcSession
+        packageState <- hscEnv <$> use_ GhcSession file
         liftIO $ compileModule packageState tms tm
 
+
+-- A local rule type to get caching. We want to use newCache, but it has
+-- thread killed exception issues, so we lift it to a full rule.
+-- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547
+type instance RuleResult GhcSessionIO = GhcSessionFun
+
+data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic)
+instance Hashable GhcSessionIO
+instance NFData   GhcSessionIO
+
+newtype GhcSessionFun = GhcSessionFun (FilePath -> Action HscEnvEq)
+instance Show GhcSessionFun where show _ = "GhcSessionFun"
+instance NFData GhcSessionFun where rnf !_ = ()
+
+
 loadGhcSession :: Rules ()
-loadGhcSession =
-    defineNoFile $ \GhcSession -> do
+loadGhcSession = do
+    defineNoFile $ \GhcSessionIO -> do
         opts <- getIdeOptions
-        optGhcSession opts
+        liftIO $ GhcSessionFun <$> optGhcSession opts
+    define $ \GhcSession file -> do
+        GhcSessionFun fun <- useNoFile_ GhcSessionIO
+        val <- fun $ fromNormalizedFilePath file
+        return ([], Just val)
 
 
 getHieFileRule :: Rules ()

src/Development/IDE/GHC/Orphans.hs

@@ -46,12 +46,6 @@ instance Show ParsedModule where
 instance NFData ModSummary where
     rnf = rwhnf
 
-instance Show HscEnv where
-    show _ = "HscEnv"
-
-instance NFData HscEnv where
-    rnf = rwhnf
-
 instance NFData ParsedModule where
     rnf = rwhnf
 

src/Development/IDE/GHC/Util.hs

@@ -16,7 +16,8 @@ module Development.IDE.GHC.Util(
     prettyPrint,
     runGhcEnv,
     textToStringBuffer,
-    moduleImportPaths
+    moduleImportPaths,
+    HscEnvEq, hscEnv, newHscEnvEq
     ) where
 
 import Config
@@ -26,11 +27,13 @@ import Fingerprint
 #endif
 import GHC
 import GhcMonad
-import GhcPlugins
+import GhcPlugins hiding (Unique)
 import Data.IORef
 import Control.Exception
 import FileCleanup
 import Platform
+import Data.Unique
+import Development.Shake.Classes
 import qualified Data.Text as T
 import StringBuffer
 import System.FilePath
@@ -110,3 +113,21 @@ moduleImportPaths pm
     mod'  = GHC.ms_mod ms
     rootPathDir  = takeDirectory file
     rootModDir   = takeDirectory . moduleNameSlashes . GHC.moduleName $ mod'
+
+-- | An HscEnv with equality.
+data HscEnvEq = HscEnvEq Unique HscEnv
+
+hscEnv :: HscEnvEq -> HscEnv
+hscEnv (HscEnvEq _ x) = x
+
+newHscEnvEq :: HscEnv -> IO HscEnvEq
+newHscEnvEq e = do u <- newUnique; return $ HscEnvEq u e
+
+instance Show HscEnvEq where
+  show (HscEnvEq a _) = "HscEnvEq " ++ show (hashUnique a)
+
+instance Eq HscEnvEq where
+  HscEnvEq a _ == HscEnvEq b _ = a == b
+
+instance NFData HscEnvEq where
+  rnf (HscEnvEq a b) = rnf (hashUnique a) `seq` b `seq` ()

src/Development/IDE/Types/Options.hs

@@ -14,23 +14,36 @@ module Development.IDE.Types.Options
 
 import Data.Maybe
 import Development.Shake
+import Development.IDE.GHC.Util
 import           GHC hiding (parseModule, typecheckModule)
 import           GhcPlugins                     as GHC hiding (fst3, (<>))
 import qualified Language.Haskell.LSP.Types.Capabilities as LSP
 
 data IdeOptions = IdeOptions
   { optPreprocessor :: GHC.ParsedSource -> ([(GHC.SrcSpan, String)], GHC.ParsedSource)
-  , optGhcSession :: Action HscEnv
-  -- ^ Setup a GHC session using a given package state. If a `ParsedModule` is supplied,
-  -- the import path should be setup for that module.
+    -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings
+    --   along with a new parse tree.
+  , optGhcSession :: IO (FilePath -> Action HscEnvEq)
+    -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@.
+    --   The 'IO' will be called once, then the resulting function will be applied once per file.
+    --   It is desirable that many files get the same 'HscEnvEq', so that more IDE features work.
+    --   You should not use 'newCacheIO' to get that caching, because of
+    --   https://github.com/ndmitchell/shake/issues/725.
   , optPkgLocationOpts :: IdePkgLocationOptions
+    -- ^ How to locate source and @.hie@ files given a module name.
   , optExtensions :: [String]
+    -- ^ File extensions to search for code, defaults to Haskell sources (including @.hs@)
 
   , optThreads :: Int
+    -- ^ Number of threads to use. Use 0 for number of threads on the machine.
   , optShakeProfiling :: Maybe FilePath
+    -- ^ Set to 'Just' to create a directory of profiling reports.
   , optReportProgress :: IdeReportProgress
-  , optLanguageSyntax :: String -- ^ the ```language to use
-  , optNewColonConvention :: Bool -- ^ whether to use new colon convention
+    -- ^ Whether to report progress during long operations.
+  , optLanguageSyntax :: String
+    -- ^ the ```language to use
+  , optNewColonConvention :: Bool
+    -- ^ whether to use new colon convention
   }
 
 newtype IdeReportProgress = IdeReportProgress Bool
@@ -39,7 +52,7 @@ clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress
 clientSupportsProgress caps = IdeReportProgress $ fromMaybe False $
     LSP._progress =<< LSP._window (caps :: LSP.ClientCapabilities)
 
-defaultIdeOptions :: Action HscEnv -> IdeOptions
+defaultIdeOptions :: IO (FilePath -> Action HscEnvEq) -> IdeOptions
 defaultIdeOptions session = IdeOptions
     {optPreprocessor = (,) []
     ,optGhcSession = session