@@ -8,14 +8,11 @@
88module Main(main) where
99
1010import Arguments
11−import Data.Binary (Binary)
12−import Data.Dynamic (Typeable)
13−import Data.Hashable (Hashable)
11+import Data.Functor ((<&>))
1412import Data.Maybe
1513import Data.List.Extra
1614import System.FilePath
1715import Control.Concurrent.Extra
18−import Control.DeepSeq (NFData)
1916import Control.Exception
2017import Control.Monad.Extra
2118import Control.Monad.IO.Class
@@ -53,12 +50,11 @@ import System.IO
5350import System.Exit
5451import Paths_ghcide
5552import Development.GitRev
56−import Development.Shake (Action, RuleResult, Rules, action, doesFileExist, need)
53+import Development.Shake (doesDirectoryExist, Action, Rules, action, doesFileExist, need)
5754import qualified Data.HashSet as HashSet
5855import qualified Data.Map.Strict as Map
5956
6057import GHC hiding (def)
61−import GHC.Generics (Generic)
6258import qualified GHC.Paths
6359import DynFlags
6460
@@ -66,6 +62,7 @@ import HIE.Bios.Environment
6662import HIE.Bios
6763import HIE.Bios.Cradle
6864import HIE.Bios.Types
65+import RuleTypes
6966
7067-- Prefix for the cache path
7168cacheDir :: String
@@ -127,7 +124,7 @@ main = do
127124 , optShakeProfiling = argsShakeProfiling
128125 }
129126 debouncer <- newAsyncDebouncer
130− initialise caps (loadGhcSessionIO >> mainRule >> pluginRules plugins >> action kick)
127+ initialise caps (cradleRules >> mainRule >> pluginRules plugins >> action kick)
131128 getLspId event (logger minBound) debouncer options vfs
132129 else do
133130 putStrLn $ "Ghcide setup tester in " ++ dir ++ "."
@@ -164,7 +161,7 @@ main = do
164161 let options =
165162 (defaultIdeOptions $ return $ return . grab)
166163 { 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
168165
169166 putStrLn "\nStep 6/6: Type checking the files"
170167 setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath files
@@ -178,6 +175,10 @@ main = do
178175
179176 unless (null failed) exitFailure
180177
178+cradleRules :: Rules ()
179+cradleRules = do
180+ loadGhcSessionIO
181+ cradleToSession
181182
182183expandFiles :: [FilePath] -> IO [FilePath]
183184expandFiles = concatMapM $ \x -> do
@@ -204,20 +205,6 @@ showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =
204205 withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags
205206showEvent lock e = withLock lock $ print e
206207
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−
221208loadGhcSessionIO :: Rules ()
222209loadGhcSessionIO =
223210 -- This rule is for caching the GHC session. E.g., even when the cabal file
@@ -226,10 +213,10 @@ loadGhcSessionIO =
226213 defineNoFile $ \(GetHscEnv opts deps) ->
227214 liftIO $ createSession $ ComponentOptions opts deps
228215
229−
230216getComponentOptions :: Cradle a -> IO ComponentOptions
231217getComponentOptions cradle = do
232218 let showLine s = putStrLn ("> " ++ s)
219+ -- WARNING 'runCradle is very expensive and must be called as few times as possible
233220 cradleRes <- runCradle (cradleOptsProg cradle) showLine ""
234221 case cradleRes of
235222 CradleSuccess r -> pure r
@@ -285,8 +272,14 @@ setHiDir f d =
285272 -- override user settings to avoid conflicts leading to recompilation
286273 d { hiDir = Just f}
287274
288−cradleToSession :: Maybe FilePath -> Cradle a -> Action HscEnvEq
289−cradleToSession mbYaml cradle = do
275+cradleToSession :: Rules ()
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+
290283 cmpOpts <- liftIO $ getComponentOptions cradle
291284 let opts = componentOptions cmpOpts
292285 deps = componentDependencies cmpOpts
@@ -296,7 +289,7 @@ cradleToSession mbYaml cradle = do
296289 _ -> deps
297290 existingDeps <- filterM doesFileExist deps'
298291 need existingDeps
299− useNoFile_ $ GetHscEnv opts deps
292+ ([],) . pure <$> useNoFile_ (GetHscEnv opts deps)
300293
301294
302295loadSession :: FilePath -> Action (FilePath -> Action HscEnvEq)
@@ -310,8 +303,9 @@ loadSession dir = liftIO $ do
310303 return $ normalise <$> res'
311304 let session :: Maybe FilePath -> Action HscEnvEq
312305 session file = do
313− c <- liftIO $ maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle file
314− cradleToSession file c
306+ -- In the absence of a cradle file, just pass the directory from where to calculate an implicit cradle
307+ let cradle = toNormalizedFilePath $ fromMaybe dir file
308+ use_ LoadCradle cradle
315309 return $ \file -> session =<< liftIO (cradleLoc file)
316310
317311