02221d9 · ghcide · git.iko.soy

git.iko.soy/ghcide

on master help sign in

Merge pull request #24 from ndmitchell/multienv

02221d9Moritz Kiefer7 years ago

exe/Main.hs+12−7

compare with master

unifiedsplit

@@ -23,6 +23,7 @@ import Development.IDE.Types.Location

23import Development.IDE.Types.Diagnostics

24import Development.IDE.Types.Options

25import Development.IDE.Types.Logger

26+import Development.IDE.GHC.Util

26import qualified Data.Text as T

27import qualified Data.Text as T

27import qualified Data.Text.IO as T

28import qualified Data.Text.IO as T

28import Language.Haskell.LSP.Messages

29import Language.Haskell.LSP.Messages

@@ -36,9 +37,6 @@ import System.IO

36import Development.Shake hiding (Env)

37import Development.Shake hiding (Env)

37import qualified Data.Set as Set

38import qualified Data.Set as Set

39−-- import CmdLineParser

40−-- import DynFlags

41−-- import Panic

42import GHC hiding (def)

40import GHC hiding (def)

43import qualified GHC.Paths

41import qualified GHC.Paths

@@ -71,10 +69,12 @@ main = do

71 runLanguageServer def def $ \event vfs caps -> do

69 runLanguageServer def def $ \event vfs caps -> do

72 t <- t

70 t <- t

73 hPutStrLn stderr $ "Started LSP server in " ++ showDuration t

71 hPutStrLn stderr $ "Started LSP server in " ++ showDuration t

74− let options = (defaultIdeOptions $ liftIO $ newSession' =<< findCradle (dir <> "/"))

72+ let options = (defaultIdeOptions $ loadEnvironment dir)

75 { optReportProgress = clientSupportsProgress caps }

73 { optReportProgress = clientSupportsProgress caps }

76 initialise (mainRule >> action kick) event logger options vfs

74 initialise (mainRule >> action kick) event logger options vfs

77 else do

75 else do

76+ -- Note that this whole section needs to change once we have genuine

77+ -- multi environment support. Needs rewriting in terms of loadEnvironment.

78 putStrLn "[1/6] Finding hie-bios cradle"

79 cradle <- findCradle (dir <> "/")

80 print cradle

@@ -84,7 +84,7 @@ main = do

85 putStrLn "\n[3/6] Initialising IDE session"

86 vfs <- makeVFSHandle

87− ide <- initialise mainRule (showEvent lock) logger (defaultIdeOptions $ return env) vfs

87+ ide <- initialise mainRule (showEvent lock) logger (defaultIdeOptions $ return $ const $ return env) vfs

89 putStrLn "\n[4/6] Finding interesting files"

90 files <- nubOrd <$> expandFiles (argFiles ++ ["." | null argFiles])

@@ -128,10 +128,15 @@ showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =

128 withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,) diags

129showEvent lock e = withLock lock $ print e

130

131−newSession' :: Cradle -> IO HscEnv

131+newSession' :: Cradle -> IO HscEnvEq

132newSession' cradle = getLibdir >>= \libdir -> do

133 env <- runGhc (Just libdir) $ do

134 initializeFlagsWithCradle "" cradle

135 getSession

136 initDynLinker env

137− pure env

137+ newHscEnvEq env

138+

139+loadEnvironment :: FilePath -> IO (FilePath -> Action HscEnvEq)

140+loadEnvironment dir = do

141+ res <- liftIO $ newSession' =<< findCradle (dir <> "/")

142+ return $ const $ return res

src/Development/IDE/Core/RuleTypes.hs+2−1

@@ -13,6 +13,7 @@ module Development.IDE.Core.RuleTypes(

14import Control.DeepSeq

15import Development.IDE.Import.DependencyInformation

16+import Development.IDE.GHC.Util

16import Development.IDE.Types.Location

17import Development.IDE.Types.Location

17import Data.Hashable

18import Data.Hashable

18import Data.Typeable

19import Data.Typeable

@@ -66,7 +67,7 @@ type instance RuleResult GetSpanInfo = [SpanInfo]

66type instance RuleResult GenerateCore = CoreModule

67type instance RuleResult GenerateCore = CoreModule

68-- | A GHC session that we reuse.

69-- | A GHC session that we reuse.

69−type instance RuleResult GhcSession = HscEnv

70+type instance RuleResult GhcSession = HscEnvEq

71-- | Resolve the imports in a module to the file path of a module

72-- | Resolve the imports in a module to the file path of a module

72-- in the same package or the package id of another package.

73-- in the same package or the package id of another package.

src/Development/IDE/Core/Rules.hs+34−11

@@ -36,6 +36,7 @@ import Development.IDE.Import.FindImports

36import Development.IDE.Core.FileStore

37import Development.IDE.Types.Diagnostics

38import Development.IDE.Types.Location

39+import Development.IDE.GHC.Util

39import Data.Coerce

40import Data.Coerce

40import Data.Either.Extra

41import Data.Either.Extra

41import Data.Maybe

42import Data.Maybe

@@ -54,10 +55,12 @@ import Development.IDE.GHC.Compat

54import UniqSupply

55import UniqSupply

55import NameCache

56import NameCache

56import HscTypes

57import HscTypes

58+import GHC.Generics(Generic)

58import qualified Development.IDE.Spans.AtPoint as AtPoint

60import qualified Development.IDE.Spans.AtPoint as AtPoint

59import Development.IDE.Core.Service

61import Development.IDE.Core.Service

60import Development.IDE.Core.Shake

62import Development.IDE.Core.Shake

63+import Development.Shake.Classes

61import System.Directory

64import System.Directory

62import System.FilePath

65import System.FilePath

63import MkIface

66import MkIface

@@ -116,7 +119,7 @@ getAtPoint file pos = fmap join $ runMaybeT $ do

116getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)

119getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)

117getDefinition file pos = fmap join $ runMaybeT $ do

120getDefinition file pos = fmap join $ runMaybeT $ do

118 spans <- useE GetSpanInfo file

121 spans <- useE GetSpanInfo file

119− pkgState <- useNoFileE GhcSession

122+ pkgState <- hscEnv <$> useE GhcSession file

120 opts <- lift getIdeOptions

123 opts <- lift getIdeOptions

121 let getHieFile x = useNoFile (GetHieFile x)

124 let getHieFile x = useNoFile (GetHieFile x)

122 lift $ AtPoint.gotoDefinition getHieFile opts pkgState spans pos

125 lift $ AtPoint.gotoDefinition getHieFile opts pkgState spans pos

@@ -131,8 +134,9 @@ writeIfacesAndHie ::

131writeIfacesAndHie ifDir files =

134writeIfacesAndHie ifDir files =

132 runMaybeT $ do

135 runMaybeT $ do

133 tcms <- usesE TypeCheck files

136 tcms <- usesE TypeCheck files

137+ fmap concat $ forM (zip files tcms) $ \(file, tcm) -> do

134− session <- lift $ useNoFile_ GhcSession

138+ session <- lift $ hscEnv <$> use_ GhcSession file

135− liftIO $ concat <$> mapM (writeTcm session) tcms

139+ liftIO $ writeTcm session tcm

136 where

140 where

137 writeTcm session tcm =

141 writeTcm session tcm =

138 do

142 do

@@ -174,7 +178,7 @@ getParsedModuleRule :: Rules ()

174getParsedModuleRule =

178getParsedModuleRule =

175 define $ \GetParsedModule file -> do

179 define $ \GetParsedModule file -> do

176 (_, contents) <- getFileContents file

180 (_, contents) <- getFileContents file

177− packageState <- useNoFile_ GhcSession

181+ packageState <- hscEnv <$> use_ GhcSession file

178 opt <- getIdeOptions

182 opt <- getIdeOptions

179 liftIO $ parseModule opt packageState (fromNormalizedFilePath file) contents

183 liftIO $ parseModule opt packageState (fromNormalizedFilePath file) contents

180

184

@@ -184,7 +188,7 @@ getLocatedImportsRule =

184 pm <- use_ GetParsedModule file

188 pm <- use_ GetParsedModule file

185 let ms = pm_mod_summary pm

189 let ms = pm_mod_summary pm

186 let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]

190 let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]

187− env <- useNoFile_ GhcSession

191+ env <- hscEnv <$> useNoFile_ GhcSession

188 let dflags = addRelativeImport pm $ hsc_dflags env

192 let dflags = addRelativeImport pm $ hsc_dflags env

189 opt <- getIdeOptions

193 opt <- getIdeOptions

190 (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do

194 (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do

@@ -295,7 +299,7 @@ getSpanInfoRule =

295 define $ \GetSpanInfo file -> do

299 define $ \GetSpanInfo file -> do

296 tc <- use_ TypeCheck file

300 tc <- use_ TypeCheck file

297 (fileImports, _) <- use_ GetLocatedImports file

301 (fileImports, _) <- use_ GetLocatedImports file

298− packageState <- useNoFile_ GhcSession

302+ packageState <- hscEnv <$> use_ GhcSession file

299 x <- liftIO $ getSrcSpanInfos packageState fileImports tc

303 x <- liftIO $ getSrcSpanInfos packageState fileImports tc

300 return ([], Just x)

304 return ([], Just x)

301

305

@@ -307,7 +311,7 @@ typeCheckRule =

307 deps <- use_ GetDependencies file

311 deps <- use_ GetDependencies file

308 tms <- uses_ TypeCheck (transitiveModuleDeps deps)

312 tms <- uses_ TypeCheck (transitiveModuleDeps deps)

309 setPriority priorityTypeCheck

313 setPriority priorityTypeCheck

310− packageState <- useNoFile_ GhcSession

314+ packageState <- hscEnv <$> use_ GhcSession file

311 liftIO $ typecheckModule packageState tms pm

315 liftIO $ typecheckModule packageState tms pm

312

316

313

317

@@ -317,14 +321,33 @@ generateCoreRule =

317 deps <- use_ GetDependencies file

321 deps <- use_ GetDependencies file

318 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)

322 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)

319 setPriority priorityGenerateCore

323 setPriority priorityGenerateCore

320− packageState <- useNoFile_ GhcSession

324+ packageState <- hscEnv <$> use_ GhcSession file

321 liftIO $ compileModule packageState tms tm

325 liftIO $ compileModule packageState tms tm

322

326

327+

328+-- A local rule type to get caching. We want to use newCache, but it has

329+-- thread killed exception issues, so we lift it to a full rule.

330+-- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547

331+type instance RuleResult GhcSessionIO = GhcSessionFun

332+

333+data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic)

334+instance Hashable GhcSessionIO

335+instance NFData GhcSessionIO

336+

337+newtype GhcSessionFun = GhcSessionFun (FilePath -> Action HscEnvEq)

338+instance Show GhcSessionFun where show _ = "GhcSessionFun"

339+instance NFData GhcSessionFun where rnf !_ = ()

340+

341+

323loadGhcSession :: Rules ()

342loadGhcSession :: Rules ()

324−loadGhcSession =

343+loadGhcSession = do

325− defineNoFile $ \GhcSession -> do

344+ defineNoFile $ \GhcSessionIO -> do

326 opts <- getIdeOptions

345 opts <- getIdeOptions

327− optGhcSession opts

346+ liftIO $ GhcSessionFun <$> optGhcSession opts

347+ define $ \GhcSession file -> do

348+ GhcSessionFun fun <- useNoFile_ GhcSessionIO

349+ val <- fun $ fromNormalizedFilePath file

350+ return ([], Just val)

328

351

329

352

330getHieFileRule :: Rules ()

353getHieFileRule :: Rules ()

src/Development/IDE/GHC/Orphans.hs−6

@@ -46,12 +46,6 @@ instance Show ParsedModule where

46instance NFData ModSummary where

47 rnf = rwhnf

49−instance Show HscEnv where

50− show _ = "HscEnv"

51−

52−instance NFData HscEnv where

53− rnf = rwhnf

54−

55instance NFData ParsedModule where

49instance NFData ParsedModule where

56 rnf = rwhnf

50 rnf = rwhnf

src/Development/IDE/GHC/Util.hs+23−2

@@ -16,7 +16,8 @@ module Development.IDE.GHC.Util(

16 prettyPrint,

17 runGhcEnv,

18 textToStringBuffer,

19− moduleImportPaths

19+ moduleImportPaths,

20+ HscEnvEq, hscEnv, newHscEnvEq

20 ) where

21 ) where

22import Config

23import Config

@@ -26,11 +27,13 @@ import Fingerprint

26#endif

27#endif

27import GHC

28import GHC

28import GhcMonad

29import GhcMonad

29−import GhcPlugins

30+import GhcPlugins hiding (Unique)

30import Data.IORef

31import Data.IORef

31import Control.Exception

32import Control.Exception

32import FileCleanup

33import FileCleanup

33import Platform

34import Platform

35+import Data.Unique

36+import Development.Shake.Classes

34import qualified Data.Text as T

37import qualified Data.Text as T

35import StringBuffer

38import StringBuffer

36import System.FilePath

39import System.FilePath

@@ -110,3 +113,21 @@ moduleImportPaths pm

110 mod' = GHC.ms_mod ms

113 mod' = GHC.ms_mod ms

111 rootPathDir = takeDirectory file

114 rootPathDir = takeDirectory file

112 rootModDir = takeDirectory . moduleNameSlashes . GHC.moduleName $ mod'

115 rootModDir = takeDirectory . moduleNameSlashes . GHC.moduleName $ mod'

116+

117+-- | An HscEnv with equality.

118+data HscEnvEq = HscEnvEq Unique HscEnv

119+

120+hscEnv :: HscEnvEq -> HscEnv

121+hscEnv (HscEnvEq _ x) = x

122+

123+newHscEnvEq :: HscEnv -> IO HscEnvEq

124+newHscEnvEq e = do u <- newUnique; return $ HscEnvEq u e

125+

126+instance Show HscEnvEq where

127+ show (HscEnvEq a _) = "HscEnvEq " ++ show (hashUnique a)

128+

129+instance Eq HscEnvEq where

130+ HscEnvEq a _ == HscEnvEq b _ = a == b

131+

132+instance NFData HscEnvEq where

133+ rnf (HscEnvEq a b) = rnf (hashUnique a) `seq` b `seq` ()

src/Development/IDE/Types/Options.hs+19−6

@@ -14,23 +14,36 @@ module Development.IDE.Types.Options

15import Data.Maybe

16import Development.Shake

17+import Development.IDE.GHC.Util

17import GHC hiding (parseModule, typecheckModule)

18import GHC hiding (parseModule, typecheckModule)

18import GhcPlugins as GHC hiding (fst3, (<>))

19import GhcPlugins as GHC hiding (fst3, (<>))

19import qualified Language.Haskell.LSP.Types.Capabilities as LSP

20import qualified Language.Haskell.LSP.Types.Capabilities as LSP

21data IdeOptions = IdeOptions

22data IdeOptions = IdeOptions

22 { optPreprocessor :: GHC.ParsedSource -> ([(GHC.SrcSpan, String)], GHC.ParsedSource)

23 { optPreprocessor :: GHC.ParsedSource -> ([(GHC.SrcSpan, String)], GHC.ParsedSource)

24+ -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings

25+ -- along with a new parse tree.

23− , optGhcSession :: Action HscEnv

26+ , optGhcSession :: IO (FilePath -> Action HscEnvEq)

24− -- ^ Setup a GHC session using a given package state. If a `ParsedModule` is supplied,

27+ -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@.

25− -- the import path should be setup for that module.

28+ -- The 'IO' will be called once, then the resulting function will be applied once per file.

29+ -- It is desirable that many files get the same 'HscEnvEq', so that more IDE features work.

30+ -- You should not use 'newCacheIO' to get that caching, because of

31+ -- https://github.com/ndmitchell/shake/issues/725.

26 , optPkgLocationOpts :: IdePkgLocationOptions

32 , optPkgLocationOpts :: IdePkgLocationOptions

33+ -- ^ How to locate source and @.hie@ files given a module name.

27 , optExtensions :: [String]

34 , optExtensions :: [String]

35+ -- ^ File extensions to search for code, defaults to Haskell sources (including @.hs@)

29 , optThreads :: Int

37 , optThreads :: Int

38+ -- ^ Number of threads to use. Use 0 for number of threads on the machine.

30 , optShakeProfiling :: Maybe FilePath

39 , optShakeProfiling :: Maybe FilePath

40+ -- ^ Set to 'Just' to create a directory of profiling reports.

31 , optReportProgress :: IdeReportProgress

41 , optReportProgress :: IdeReportProgress

42+ -- ^ Whether to report progress during long operations.

32− , optLanguageSyntax :: String -- ^ the ```language to use

43+ , optLanguageSyntax :: String

44+ -- ^ the ```language to use

45+ , optNewColonConvention :: Bool

33− , optNewColonConvention :: Bool -- ^ whether to use new colon convention

46+ -- ^ whether to use new colon convention

34 }

47 }

36newtype IdeReportProgress = IdeReportProgress Bool

49newtype IdeReportProgress = IdeReportProgress Bool

@@ -39,7 +52,7 @@ clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress

39clientSupportsProgress caps = IdeReportProgress $ fromMaybe False $

52clientSupportsProgress caps = IdeReportProgress $ fromMaybe False $

40 LSP._progress =<< LSP._window (caps :: LSP.ClientCapabilities)

53 LSP._progress =<< LSP._window (caps :: LSP.ClientCapabilities)

42−defaultIdeOptions :: Action HscEnv -> IdeOptions

55+defaultIdeOptions :: IO (FilePath -> Action HscEnvEq) -> IdeOptions

43defaultIdeOptions session = IdeOptions

56defaultIdeOptions session = IdeOptions

44 {optPreprocessor = (,) []

57 {optPreprocessor = (,) []

45 ,optGhcSession = session

58 ,optGhcSession = session