First attempt at multi component support

exe/Main.hs

@@ -1,14 +1,18 @@
 -- Copyright (c) 2019 The DAML Authors. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
 {-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above
+{-# OPTIONS_GHC -Wno-orphans #-}
 {-# LANGUAGE CPP #-} -- To get precise GHC version
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StandaloneDeriving #-}
 
 module Main(main) where
 
+import Module
 import Arguments
 import Data.Maybe
 import Data.List.Extra
+import Data.Void
 import System.FilePath
 import Control.Concurrent.Extra
 import Control.Exception
@@ -47,6 +51,9 @@ import Development.Shake (Action, action)
 import qualified Data.Set as Set
 import qualified Data.Map.Strict as Map
 
+import GhcMonad
+import HscTypes (HscEnv(..), ic_dflags)
+import DynFlags (parseDynamicFlagsFull, flagsPackage, flagsDynamic)
 import GHC hiding (def)
 import qualified GHC.Paths
 
@@ -119,24 +126,12 @@ main = do
         let ucradles = nubOrd cradles
         let n = length ucradles
         putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
-        sessions <- forM (zipFrom (1 :: Int) ucradles) $ \(i, x) -> do
-            let msg = maybe ("Implicit cradle for " ++ dir) ("Loading " ++) x
-            putStrLn $ "\nStep 3/6, Cradle " ++ show i ++ "/" ++ show n ++ ": " ++ msg
-            cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle x
-            when (isNothing x) $ print cradle
-            putStrLn $ "\nStep 4/6, Cradle " ++ show i ++ "/" ++ show n ++ ": Loading GHC Session"
-            cradleToSession cradle
-
-        putStrLn "\nStep 5/6: Initializing the IDE"
+        putStrLn "\nStep 3/6: Initializing the IDE"
         vfs <- makeVFSHandle
-        let cradlesToSessions = Map.fromList $ zip ucradles sessions
-        let filesToCradles = Map.fromList $ zip files cradles
-        let grab file = fromMaybe (head sessions) $ do
-                cradle <- Map.lookup file filesToCradles
-                Map.lookup cradle cradlesToSessions
-        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) (defaultIdeOptions $ return $ return . grab) vfs
-
-        putStrLn "\nStep 6/6: Type checking the files"
+        grab <- loadSession dir
+        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) (defaultIdeOptions $ return grab) vfs
+
+        putStrLn "\nStep 4/6: Type checking the files"
         setFilesOfInterest ide $ Set.fromList $ map toNormalizedFilePath files
         results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath files
         let (worked, failed) = partition fst $ zip (map isJust results) files
@@ -175,37 +170,101 @@ showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =
 showEvent lock e = withLock lock $ print e
 
 
-cradleToSession :: Cradle -> IO HscEnvEq
-cradleToSession cradle = do
-    cradleRes <- getCompilerOptions "" cradle
+cradleToSessionOpts :: Cradle Void -> FilePath -> IO ComponentOptions
+cradleToSessionOpts cradle file = do
+
+    cradleRes <- getCompilerOptions file cradle
     opts <- case cradleRes of
         CradleSuccess r -> pure r
         CradleFail err -> throwIO err
         -- TODO Rather than failing here, we should ignore any files that use this cradle.
         -- That will require some more changes.
         CradleNone -> fail "'none' cradle is not yet supported"
+    pure opts
+
+emptyHscEnv :: IO HscEnv
+emptyHscEnv = do
     libdir <- getLibdir
-    env <- runGhc (Just libdir) $ do
-        _targets <- initSession opts
-        getSession
+    env <- runGhc (Just libdir) getSession
     initDynLinker env
-    newHscEnvEq env
+    pure env
 
+addPackageOpts :: HscEnv -> ComponentOptions -> IO HscEnv
+addPackageOpts hscEnv opts = do
+    runGhcEnv hscEnv $ do
+        df <- getSessionDynFlags
+        (df', _, _) <- parseDynamicFlagsFull flagsPackage True df (map noLoc $ componentOptions opts)
+        _targets <- setSessionDynFlags df'
+        getSession
+
+tweakHscEnv :: HscEnv -> ComponentOptions -> IO HscEnv
+tweakHscEnv hscEnv opts = do
+    runGhcEnv hscEnv $ do
+        df <- getSessionDynFlags
+        (df', _, _) <- parseDynamicFlagsFull flagsDynamic True df (map noLoc $ componentOptions opts)
+        modifySession $ \h -> h { hsc_dflags = df', hsc_IC = (hsc_IC h) { ic_dflags = df' } }
+        getSession
+
+deriving instance Ord ComponentOptions
+
+targetToFile :: TargetId -> (NormalizedFilePath, Bool)
+targetToFile (TargetModule mod) = (toNormalizedFilePath $ (moduleNameSlashes mod) -<.> "hs", False)
+targetToFile (TargetFile f _) = (toNormalizedFilePath f, True)
 
 loadSession :: FilePath -> IO (FilePath -> Action HscEnvEq)
 loadSession dir = do
+    hscEnvs <- newVar Map.empty
+    fileToFlags <- newVar []
+    -- This caches the mapping from Mod.hs -> hie.yaml
     cradleLoc <- memoIO $ \v -> do
         res <- findCradle v
         -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
         -- try and normalise that
         -- e.g. see https://github.com/digital-asset/ghcide/issues/126
         res' <- traverse makeAbsolute res
         return $ normalise <$> res'
-    session <- memoIO $ \file -> do
-        c <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle file
-        cradleToSession c
-    return $ \file -> liftIO $ session =<< cradleLoc file
 
+    packageSetup <- memoIO $ \(hieYaml, opts) -> do
+        hscEnv <- emptyHscEnv
+        -- TODO This should definitely not call initSession
+        targets <- runGhcEnv hscEnv $ initSession opts
+        modifyVar_ fileToFlags $ \var -> do
+            let xs = map (\target -> (targetToFile $ targetId target,opts)) targets
+            print (map (fromNormalizedFilePath . fst . fst) xs)
+            pure $ xs ++ var
+        -- print (hieYaml, opts)
+        modifyVar_ hscEnvs $ \m -> do
+            oldHscEnv <- case Map.lookup hieYaml m of
+                Nothing -> emptyHscEnv
+                Just hscEnv -> pure hscEnv
+            newHscEnv <- addPackageOpts oldHscEnv opts
+            pure (Map.insert hieYaml newHscEnv m)
+
+    session <- memoIO $ \(hieYaml, opts) -> do
+        packageSetup (hieYaml, opts)
+        hscEnv <- fmap (Map.lookup hieYaml) $ readVar hscEnvs
+        -- TODO Handle the case where there is no hie.yaml
+        newHscEnvEq =<< tweakHscEnv (fromJust hscEnv) opts
+
+    lock <- newLock
+
+    -- This caches the mapping from hie.yaml + Mod.hs -> [String]
+    sessionOpts <- memoIO $ \(hieYaml, file) -> withLock lock $ do
+        v <- readVar fileToFlags
+        -- We sort so exact matches come first.
+        case find (\((f', exact), _) -> fromNormalizedFilePath f' == file || not exact && fromNormalizedFilePath f' `isSuffixOf` file) v of
+            Just (_, opts) -> do
+                putStrLn $ "Cached component of " <> show file
+                pure opts
+            Nothing-> do
+                putStrLn $ "Shelling out to cabal " <> show file
+                cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle hieYaml
+                opts <- cradleToSessionOpts cradle file
+                pure opts
+    return $ \file -> liftIO $ do
+        hieYaml <- cradleLoc file
+        opts <- sessionOpts (hieYaml, file)
+        session (hieYaml, opts)
 
 -- | Memoize an IO function, with the characteristics:
 --

ghcide.cabal

@@ -143,7 +143,7 @@ library
 executable ghcide-test-preprocessor
     default-language: Haskell2010
     hs-source-dirs: test/preprocessor
-    ghc-options: -Wall
+    ghc-options: -Wall -Wno-name-shadowing
     main-is: Main.hs
     build-depends:
         base == 4.*

hie.yaml

@@ -1 +1,12 @@
-cradle: {stack: {component: "ghcide:lib"}}
+cradle:
+  cabal:
+    - path: "./src"
+      component: "ghcide:lib:ghcide"
+    - path: "./exe"
+      component: "ghcide:exe:ghcide"
+    - path: "./test"
+      component: "ghcide:test:ghcide-tests"
+    - path: "./test/preprocessor"
+      component: "ghcide:exe:ghcide-test-preprocessor"
+    - path: ".stack-work/dist/x86_64-linux/Cabal-2.4.0.1/build/ghcide/autogen"
+      component: "ghcide:exe:ghcide"

stack.yaml

@@ -5,11 +5,12 @@ extra-deps:
 - haskell-lsp-0.19.0.0
 - haskell-lsp-types-0.19.0.0
 - lsp-test-0.10.0.0
-- hie-bios-0.3.2
 - fuzzy-0.1.0.0
 - regex-pcre-builtin-0.95.1.1.8.43
 - regex-base-0.94.0.0
 - regex-tdfa-1.3.1.0
 - parser-combinators-1.2.1
+- git: https://github.com/mpickering/hie-bios.git
+  commit: d9f602326526ded2bba4ae07d4125b10c6f66ffa
 nix:
   packages: [zlib]