@@ -39,6 +39,7 @@ import System.Exit
3939import Paths_ghcide
4040import Development.Shake hiding (Env)
4141import qualified Data.Set as Set
42+import qualified Data.Map.Strict as Map
4243
4344import GHC hiding (def)
4445import qualified GHC.Paths
@@ -64,13 +65,12 @@ main = do
6465
6566 -- lock to avoid overlapping output on stdout
6667 lock <- newLock
67− let logger = Logger $ \pri msg -> withLock lock $
68+ let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $
6869 T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
6970
7071 whenJust argsCwd setCurrentDirectory
7172
7273 dir <- getCurrentDirectory
73− hPutStrLn stderr dir
7474
7575 if argLSP then do
7676 t <- offsetTime
@@ -78,31 +78,43 @@ main = do
7878 runLanguageServer def def $ \event vfs caps -> do
7979 t <- t
8080 hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
81− let options = (defaultIdeOptions $ loadEnvironment dir)
81+ -- very important we only call loadSession once, and it's fast, so just do it before starting
82+ session <- loadSession dir
83+ let options = (defaultIdeOptions $ return session)
8284 { optReportProgress = clientSupportsProgress caps }
83− initialise (mainRule >> action kick) event logger options vfs
85+ initialise (mainRule >> action kick) event (logger minBound) options vfs
8486 else do
85− -- Note that this whole section needs to change once we have genuine
86− -- multi environment support. Needs rewriting in terms of loadEnvironment.
87− putStrLn "[1/6] Finding hie-bios cradle"
88− cradle <- getCradle dir
89− print cradle
87+ putStrLn $ "Ghcide setup tester in " ++ dir ++ "."
88+ putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"
9089
91− putStrLn "\n[2/6] Converting Cradle to GHC session"
92− env <- newSession' cradle
93−
94− putStrLn "\n[3/6] Initialising IDE session"
95− vfs <- makeVFSHandle
96− ide <- initialise mainRule (showEvent lock) logger (defaultIdeOptions $ return $ const $ return env) vfs
97−
98− putStrLn "\n[4/6] Finding interesting files"
90+ putStrLn $ "\nStep 1/6: Finding files to test in " ++ dir
9991 files <- nubOrd <$> expandFiles (argFiles ++ ["." | null argFiles])
10092 putStrLn $ "Found " ++ show (length files) ++ " files"
10193
102− putStrLn "\n[5/6] Setting interesting files"
94+ putStrLn "\nStep 2/6: Looking for hie.yaml files that control setup"
95+ cradles <- mapM findCradle files
96+ let ucradles = nubOrd cradles
97+ let n = length ucradles
98+ putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
99+ sessions <- forM (zipFrom (1 :: Int) ucradles) $ \(i, x) -> do
100+ let msg = maybe ("Implicit cradle for " ++ dir) ("Loading " ++) x
101+ putStrLn $ "\nStep 3/6, Cradle " ++ show i ++ "/" ++ show n ++ ": " ++ msg
102+ cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle x
103+ when (isNothing x) $ print cradle
104+ putStrLn $ "\nStep 4/6, Cradle " ++ show i ++ "/" ++ show n ++ ": Loading GHC Session"
105+ cradleToSession cradle
106+
107+ putStrLn "\nStep 5/6: Initializing the IDE"
108+ vfs <- makeVFSHandle
109+ let cradlesToSessions = Map.fromList $ zip ucradles sessions
110+ let filesToCradles = Map.fromList $ zip files cradles
111+ let grab file = fromMaybe (head sessions) $ do
112+ cradle <- Map.lookup file filesToCradles
113+ Map.lookup cradle cradlesToSessions
114+ ide <- initialise mainRule (showEvent lock) (logger Info) (defaultIdeOptions $ return $ return . grab) vfs
115+
116+ putStrLn "\nStep 6/6: Type checking the files"
103117 setFilesOfInterest ide $ Set.fromList $ map toNormalizedFilePath files
104−
105− putStrLn "\n[6/6] Loading interesting files"
106118 results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath files
107119 let (worked, failed) = partition fst $ zip (map isJust results) files
108120 putStrLn $ "Files that worked: " ++ show (length worked)
@@ -137,8 +149,9 @@ showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =
137149 withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,) diags
138150showEvent lock e = withLock lock $ print e
139151
140−newSession' :: Cradle -> IO HscEnvEq
141−newSession' cradle = do
152+
153+cradleToSession :: Cradle -> IO HscEnvEq
154+cradleToSession cradle = do
142155 opts <- either throwIO return =<< getCompilerOptions "" cradle
143156 libdir <- getLibdir
144157 env <- runGhc (Just libdir) $ do
@@ -147,15 +160,33 @@ newSession' cradle = do
147160 initDynLinker env
148161 newHscEnvEq env
149162
150−loadEnvironment :: FilePath -> IO (FilePath -> Action HscEnvEq)
151−loadEnvironment dir = do
152− res <- liftIO $ newSession' =<< getCradle dir
153− return $ const $ return res
154−
155−getCradle :: FilePath -> IO Cradle
156−getCradle dir = do
157− dir <- pure $ addTrailingPathSeparator dir
158− mbYaml <- findCradle dir
159− case mbYaml of
160− Nothing -> loadImplicitCradle dir
161− Just yaml -> loadCradle yaml
163+
164+loadSession :: FilePath -> IO (FilePath -> Action HscEnvEq)
165+loadSession dir = do
166+ cradleLoc <- memoIO $ \v -> do
167+ res <- findCradle v
168+ -- Sometimes we get C: and sometimes we get c:, try and normalise that
169+ -- e.g. see https://github.com/digital-asset/ghcide/issues/126
170+ return $ normalise <$> res
171+ session <- memoIO $ \file -> do
172+ c <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle file
173+ cradleToSession c
174+ return $ \file -> liftIO $ session =<< cradleLoc file
175+
176+
177+-- | Memoize an IO function, with the characteristics:
178+--
179+-- * If multiple people ask for a result simultaneously, make sure you only compute it once.
180+--
181+-- * If there are exceptions, repeatedly reraise them.
182+--
183+-- * If the caller is aborted (async exception) finish computing it anyway.
184+memoIO :: Ord a => (a -> IO b) -> IO (a -> IO b)
185+memoIO op = do
186+ ref <- newVar Map.empty
187+ return $ \k -> join $ mask_ $ modifyVar ref $ \mp ->
188+ case Map.lookup k mp of
189+ Nothing -> do
190+ res <- onceFork $ op k
191+ return (Map.insert k res mp, res)
192+ Just res -> return (mp, res)