ff62fdd · ghcide · git.iko.soy

git.iko.soy/ghcide

on master help sign in

Fix regression in cradle loading logic (#450)

ff62fddPepe Iborra7 years ago

exe/Main.hs+22−28

compare with master

unifiedsplit

@@ -8,14 +8,11 @@

8module Main(main) where

10import Arguments

11−import Data.Binary (Binary)

11+import Data.Functor ((<&>))

12−import Data.Dynamic (Typeable)

13−import Data.Hashable (Hashable)

14import Data.Maybe

12import Data.Maybe

15import Data.List.Extra

13import Data.List.Extra

16import System.FilePath

14import System.FilePath

17import Control.Concurrent.Extra

15import Control.Concurrent.Extra

18−import Control.DeepSeq (NFData)

19import Control.Exception

16import Control.Exception

20import Control.Monad.Extra

17import Control.Monad.Extra

21import Control.Monad.IO.Class

18import Control.Monad.IO.Class

@@ -53,12 +50,11 @@ import System.IO

53import System.Exit

50import System.Exit

54import Paths_ghcide

51import Paths_ghcide

55import Development.GitRev

52import Development.GitRev

56−import Development.Shake (Action, RuleResult, Rules, action, doesFileExist, need)

53+import Development.Shake (doesDirectoryExist, Action, Rules, action, doesFileExist, need)

57import qualified Data.HashSet as HashSet

54import qualified Data.HashSet as HashSet

58import qualified Data.Map.Strict as Map

55import qualified Data.Map.Strict as Map

60import GHC hiding (def)

57import GHC hiding (def)

61−import GHC.Generics (Generic)

62import qualified GHC.Paths

58import qualified GHC.Paths

63import DynFlags

59import DynFlags

@@ -66,6 +62,7 @@ import HIE.Bios.Environment

66import HIE.Bios

62import HIE.Bios

67import HIE.Bios.Cradle

63import HIE.Bios.Cradle

68import HIE.Bios.Types

64import HIE.Bios.Types

65+import RuleTypes

70-- Prefix for the cache path

67-- Prefix for the cache path

71cacheDir :: String

68cacheDir :: String

@@ -127,7 +124,7 @@ main = do

127 , optShakeProfiling = argsShakeProfiling

124 , optShakeProfiling = argsShakeProfiling

128 }

125 }

129 debouncer <- newAsyncDebouncer

126 debouncer <- newAsyncDebouncer

130− initialise caps (loadGhcSessionIO >> mainRule >> pluginRules plugins >> action kick)

127+ initialise caps (cradleRules >> mainRule >> pluginRules plugins >> action kick)

131 getLspId event (logger minBound) debouncer options vfs

128 getLspId event (logger minBound) debouncer options vfs

132 else do

129 else do

133 putStrLn $ "Ghcide setup tester in " ++ dir ++ "."

130 putStrLn $ "Ghcide setup tester in " ++ dir ++ "."

@@ -164,7 +161,7 @@ main = do

164 let options =

161 let options =

165 (defaultIdeOptions $ return $ return . grab)

162 (defaultIdeOptions $ return $ return . grab)

166 { optShakeProfiling = argsShakeProfiling }

163 { optShakeProfiling = argsShakeProfiling }

167− ide <- initialise def (loadGhcSessionIO >> mainRule) (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs

164+ ide <- initialise def (cradleRules >> mainRule) (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs

168

165

169 putStrLn "\nStep 6/6: Type checking the files"

166 putStrLn "\nStep 6/6: Type checking the files"

170 setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath files

167 setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath files

@@ -178,6 +175,10 @@ main = do

178

175

179 unless (null failed) exitFailure

176 unless (null failed) exitFailure

180

177

178+cradleRules :: Rules ()

179+cradleRules = do

180+ loadGhcSessionIO

181+ cradleToSession

181

182

182expandFiles :: [FilePath] -> IO [FilePath]

183expandFiles :: [FilePath] -> IO [FilePath]

183expandFiles = concatMapM $ \x -> do

184expandFiles = concatMapM $ \x -> do

@@ -204,20 +205,6 @@ showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =

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

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

205showEvent lock e = withLock lock $ print e

206showEvent lock e = withLock lock $ print e

206

207

207−

208−-- Rule type for caching GHC sessions.

209−type instance RuleResult GetHscEnv = HscEnvEq

210−

211−data GetHscEnv = GetHscEnv

212− { hscenvOptions :: [String] -- componentOptions from hie-bios

213− , hscenvDependencies :: [FilePath] -- componentDependencies from hie-bios

214− }

215− deriving (Eq, Show, Typeable, Generic)

216−instance Hashable GetHscEnv

217−instance NFData GetHscEnv

218−instance Binary GetHscEnv

219−

220−

221loadGhcSessionIO :: Rules ()

208loadGhcSessionIO :: Rules ()

222loadGhcSessionIO =

209loadGhcSessionIO =

223 -- This rule is for caching the GHC session. E.g., even when the cabal file

210 -- This rule is for caching the GHC session. E.g., even when the cabal file

@@ -226,10 +213,10 @@ loadGhcSessionIO =

226 defineNoFile $ \(GetHscEnv opts deps) ->

213 defineNoFile $ \(GetHscEnv opts deps) ->

227 liftIO $ createSession $ ComponentOptions opts deps

214 liftIO $ createSession $ ComponentOptions opts deps

228

215

229−

230getComponentOptions :: Cradle a -> IO ComponentOptions

216getComponentOptions :: Cradle a -> IO ComponentOptions

231getComponentOptions cradle = do

217getComponentOptions cradle = do

232 let showLine s = putStrLn ("> " ++ s)

218 let showLine s = putStrLn ("> " ++ s)

219+ -- WARNING 'runCradle is very expensive and must be called as few times as possible

233 cradleRes <- runCradle (cradleOptsProg cradle) showLine ""

220 cradleRes <- runCradle (cradleOptsProg cradle) showLine ""

234 case cradleRes of

221 case cradleRes of

235 CradleSuccess r -> pure r

222 CradleSuccess r -> pure r

@@ -285,8 +272,14 @@ setHiDir f d =

285 -- override user settings to avoid conflicts leading to recompilation

272 -- override user settings to avoid conflicts leading to recompilation

286 d { hiDir = Just f}

273 d { hiDir = Just f}

287

274

288−cradleToSession :: Maybe FilePath -> Cradle a -> Action HscEnvEq

275+cradleToSession :: Rules ()

289−cradleToSession mbYaml cradle = do

276+cradleToSession = define $ \LoadCradle nfp -> do

277+ let f = fromNormalizedFilePath nfp

278+

279+ -- If the path points to a directory, load the implicit cradle

280+ mbYaml <- doesDirectoryExist f <&> \isDir -> if isDir then Nothing else Just f

281+ cradle <- liftIO $ maybe (loadImplicitCradle $ addTrailingPathSeparator f) loadCradle mbYaml

282+

290 cmpOpts <- liftIO $ getComponentOptions cradle

283 cmpOpts <- liftIO $ getComponentOptions cradle

291 let opts = componentOptions cmpOpts

284 let opts = componentOptions cmpOpts

292 deps = componentDependencies cmpOpts

285 deps = componentDependencies cmpOpts

@@ -296,7 +289,7 @@ cradleToSession mbYaml cradle = do

296 _ -> deps

289 _ -> deps

297 existingDeps <- filterM doesFileExist deps'

290 existingDeps <- filterM doesFileExist deps'

298 need existingDeps

291 need existingDeps

299− useNoFile_ $ GetHscEnv opts deps

292+ ([],) . pure <$> useNoFile_ (GetHscEnv opts deps)

300

293

301

294

302loadSession :: FilePath -> Action (FilePath -> Action HscEnvEq)

295loadSession :: FilePath -> Action (FilePath -> Action HscEnvEq)

@@ -310,8 +303,9 @@ loadSession dir = liftIO $ do

310 return $ normalise <$> res'

303 return $ normalise <$> res'

311 let session :: Maybe FilePath -> Action HscEnvEq

304 let session :: Maybe FilePath -> Action HscEnvEq

312 session file = do

305 session file = do

313− c <- liftIO $ maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle file

306+ -- In the absence of a cradle file, just pass the directory from where to calculate an implicit cradle

314− cradleToSession file c

307+ let cradle = toNormalizedFilePath $ fromMaybe dir file

308+ use_ LoadCradle cradle

315 return $ \file -> session =<< liftIO (cradleLoc file)

309 return $ \file -> session =<< liftIO (cradleLoc file)

316

310

317

311

exe/RuleTypes.hsnew file+33

@@ -0,0 +1,33 @@

1+{-# LANGUAGE TypeFamilies #-}

2+module RuleTypes (GetHscEnv(..), LoadCradle(..)) where

4+import Control.DeepSeq

5+import Data.Binary

6+import Data.Hashable (Hashable)

7+import Development.Shake

8+import Development.IDE.GHC.Util

9+import Data.Typeable (Typeable)

10+import GHC.Generics (Generic)

11+

12+-- Rule type for caching GHC sessions.

13+type instance RuleResult GetHscEnv = HscEnvEq

14+

15+data GetHscEnv = GetHscEnv

16+ { hscenvOptions :: [String] -- componentOptions from hie-bios

17+ , hscenvDependencies :: [FilePath] -- componentDependencies from hie-bios

18+ }

19+ deriving (Eq, Show, Typeable, Generic)

20+

21+instance Hashable GetHscEnv

22+instance NFData GetHscEnv

23+instance Binary GetHscEnv

24+

25+-- Rule type for caching cradle loading

26+type instance RuleResult LoadCradle = HscEnvEq

27+

28+data LoadCradle = LoadCradle

29+ deriving (Eq, Show, Typeable, Generic)

30+

31+instance Hashable LoadCradle

32+instance NFData LoadCradle

33+instance Binary LoadCradle

ghcide.cabal+1

@@ -194,6 +194,7 @@ executable ghcide

194 other-modules:

195 Arguments

196 Paths_ghcide

197+ RuleTypes

197

198

198 default-extensions:

199 default-extensions:

199 DeriveGeneric

200 DeriveGeneric