Experimenting with the WIP multi ghcide branch

Author: alanz

.gitmodules

@@ -10,5 +10,5 @@
 #     rm -rf path_to_submodule
 [submodule "ghcide"]
 	path = ghcide
-	url = https://github.com/digital-asset/ghcide.git
-	# url = https://github.com/alanz/ghcide.git
+	# url = https://github.com/digital-asset/ghcide.git
+	url = https://github.com/alanz/ghcide.git

exe/Main.hs

@@ -1,6 +1,8 @@
 -- 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
+{-# LANGUAGE CPP #-} -- To get precise GHC version
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -16,7 +18,10 @@ import Control.Exception
 import Control.Monad.Extra
 import Control.Monad.IO.Class
 import Data.Default
+import Data.Either
+import qualified Data.HashMap.Strict as HM
 import qualified Data.HashSet as HashSet
+import Data.IORef
 import Data.List.Extra
 import qualified Data.Map.Strict as Map
 import Data.Maybe
@@ -39,23 +44,40 @@ import Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Location
 import Development.IDE.Types.Logger
 import Development.IDE.Types.Options
-import Development.Shake (Action, Rules, action)
-import HIE.Bios
+import Development.Shake (Action,  action)
+import HIE.Bios.Environment (addCmdOpts)
 import qualified Language.Haskell.LSP.Core as LSP
 import Ide.Logger
 import Ide.Plugin
 import Ide.Plugin.Config
 import Language.Haskell.LSP.Messages
 import Language.Haskell.LSP.Types (LspId(IdInt))
-import RuleTypes
-import Rules
+import Linker (initDynLinker)
+import Module
+import NameCache
+import Packages
+-- import Paths_ghcide
 import qualified System.Directory.Extra as IO
 -- import System.Environment
 import System.Exit
 import System.FilePath
 import System.IO
 import System.Log.Logger as L
 import System.Time.Extra
+--import Outputable (pprTraceM, ppr, text)
+import qualified Crypto.Hash.SHA1               as H
+import qualified Data.ByteString.Char8          as B
+import           Data.ByteString.Base16         (encode)
+import           DynFlags                       (gopt_set, gopt_unset,
+                                                 updOptLevel)
+import GhcMonad
+import HscTypes (HscEnv(..), ic_dflags)
+import DynFlags (PackageFlag(..), PackageArg(..))
+import GHC hiding (def)
+import qualified GHC.Paths
+import           HIE.Bios.Cradle
+import           HIE.Bios.Types
+import System.Directory
 
 -- ---------------------------------------------------------------------
 
@@ -161,9 +183,10 @@ main = do
                     { optReportProgress = clientSupportsProgress caps
                     , optShakeProfiling = argsShakeProfiling
                     , optTesting        = argsTesting
+                    , optInterfaceLoadingDiagnostics = argsTesting
                     }
             debouncer <- newAsyncDebouncer
-            initialise caps (cradleRules >> mainRule >> pluginRules plugins >> action kick)
+            initialise caps (mainRule >> pluginRules plugins >> action kick)
                 getLspId event hlsLogger debouncer options vfs
     else do
         -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
@@ -184,44 +207,21 @@ 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"
-            opts <- getComponentOptions cradle
-            createSession opts
-
-        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
-
-        let options =
-              (defaultIdeOptions $ return $ return . grab)
-                    { optShakeProfiling = argsShakeProfiling }
-        ide <- initialise def (cradleRules >> mainRule) (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs
-
-        putStrLn "\nStep 6/6: Type checking the files"
+        debouncer <- newAsyncDebouncer
+        -- let options =
+        --       (defaultIdeOptions $ return $ return . grab)
+        --             { optShakeProfiling = argsShakeProfiling }
+        let options = defaultIdeOptions $ loadSession dir
+        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) debouncer options vfs
+
+        putStrLn "\nStep 4/6: Type checking the files"
         setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath files
-        results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath files
-        let (worked, failed) = partition fst $ zip (map isJust results) files
-        when (failed /= []) $
-            putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed
-
-        let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"
-        putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"
-
-        unless (null failed) exitFailure
-
-cradleRules :: Rules ()
-cradleRules = do
-    loadGhcSession
-    cradleToSession
+        _ <- runActionSync ide $ uses TypeCheck (map toNormalizedFilePath files)
+--        results <- runActionSync ide $ use TypeCheck $ toNormalizedFilePath "src/Development/IDE/Core/Rules.hs"
+--        results <- runActionSync ide $ use TypeCheck $ toNormalizedFilePath "exe/Main.hs"
+        return ()
 
 expandFiles :: [FilePath] -> IO [FilePath]
 expandFiles = concatMapM $ \x -> do
@@ -248,22 +248,189 @@ showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =
     withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags
 showEvent lock e = withLock lock $ print e
 
+
+cradleToSessionOpts :: Lock -> Cradle a -> FilePath -> IO ComponentOptions
+cradleToSessionOpts lock cradle file = do
+    let showLine s = putStrLn ("> " ++ s)
+    cradleRes <- withLock lock $ mask $ \_ -> runCradle (cradleOptsProg cradle) showLine file
+    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) getSession
+    initDynLinker env
+    pure env
+
+-- Convert a target to a list of potential absolute paths.
+-- A TargetModule can be anywhere listed by the supplied include
+-- directories
+-- A target file is a relative path but with a specific prefix so just need
+-- to canonicalise it.
+targetToFile :: [FilePath] -> TargetId -> IO [NormalizedFilePath]
+targetToFile is (TargetModule mod) = do
+    let fps = [i </> (moduleNameSlashes mod) -<.> ext | ext <- exts, i <- is ]
+        exts = ["hs", "hs-boot", "lhs"]
+    mapM (fmap (toNormalizedFilePath) . canonicalizePath) fps
+targetToFile _ (TargetFile f _) = do
+  f' <- canonicalizePath f
+  return [(toNormalizedFilePath f')]
+
+setNameCache :: IORef NameCache -> HscEnv -> HscEnv
+setNameCache nc hsc = hsc { hsc_NC = nc }
+
+-- This is the key function which implements multi-component support. All
+-- components mapping to the same hie,yaml file are mapped to the same
+-- HscEnv which is updated as new components are discovered.
 loadSession :: FilePath -> Action (FilePath -> Action HscEnvEq)
 loadSession dir = liftIO $ do
+    -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file
+    hscEnvs <- newVar Map.empty
+    -- Mapping from a filepath to HscEnv
+    fileToFlags <- newVar Map.empty
+    -- 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 IO.makeAbsolute res
         return $ normalise <$> res'
-    let session :: Maybe FilePath -> Action HscEnvEq
-        session file = do
-          -- In the absence of a cradle file, just pass the directory from where to calculate an implicit cradle
-          let cradle = toNormalizedFilePath $ fromMaybe dir file
-          use_ LoadCradle cradle
-    return $ \file -> session =<< liftIO (cradleLoc file)
 
+    -- Create a new HscEnv from a hieYaml root and a set of options
+    -- If the hieYaml file already has an HscEnv, the new component is
+    -- combined with the components in the old HscEnv into a new HscEnv
+    -- which contains both.
+    packageSetup <- return $ \(hieYaml, opts) -> do
+        -- Parse DynFlags for the newly discovered component
+        hscEnv <- emptyHscEnv
+        (df, targets) <- evalGhcEnv hscEnv $ do
+                          setOptions opts (hsc_dflags hscEnv)
+        -- Now lookup to see whether we are combining with an exisiting HscEnv
+        -- or making a new one. The lookup returns the HscEnv and a list of
+        -- information about other components loaded into the HscEnv
+        -- (unitId, DynFlag, Targets)
+        modifyVar hscEnvs $ \m -> do
+            -- Just deps if there's already an HscEnv
+            -- Nothing is it's the first time we are making an HscEnv
+            let oldDeps = Map.lookup hieYaml m
+            let -- Add the raw information about this component to the list
+                -- We will modify the unitId and DynFlags used for
+                -- compilation but these are the true source of
+                -- information.
+                new_deps = (thisInstalledUnitId df, df, targets) : maybe [] snd oldDeps
+                -- Get all the unit-ids for things in this component
+                inplace = map (\(a, _, _) -> a) new_deps
+                -- Remove all inplace dependencies from package flags for
+                -- components in this HscEnv
+                rearrange (uid, (df, uids), ts) = (uid, (df, uids, ts))
+                do_one (uid,df, ts) = rearrange (uid, removeInplacePackages inplace df, ts)
+                -- All deps, but without any packages which are also loaded
+                -- into memory
+                new_deps' = map do_one new_deps
+            -- Make a new HscEnv, we have to recompile everything from
+            -- scratch again (for now)
+            -- It's important to keep the same NameCache though for reasons
+            -- that I do not fully understand
+            print ("Making new HscEnv" ++ (show inplace))
+            hscEnv <- case oldDeps of
+                        Nothing -> emptyHscEnv
+                        Just (old_hsc, _) -> setNameCache (hsc_NC old_hsc) <$> emptyHscEnv
+            newHscEnv <-
+              -- Add the options for the current component to the HscEnv
+              evalGhcEnv hscEnv $ do
+                _ <- setSessionDynFlags df
+                getSession
+            -- Modify the map so the hieYaml now maps to the newly created
+            -- HscEnv
+            -- Returns
+            -- * the new HscEnv so it can be used to modify the
+            --   FilePath -> HscEnv map
+            -- * The information for the new component which caused this cache miss
+            -- * The modified information (without -inplace flags) for
+            --   existing packages
+            pure (Map.insert hieYaml (newHscEnv, new_deps) m, (newHscEnv, head new_deps', tail new_deps'))
+
+
+    session <- return $ \(hieYaml, opts) -> do
+        (hscEnv, new, old_deps) <- packageSetup (hieYaml, opts)
+        -- TODO Handle the case where there is no hie.yaml
+        -- Make a map from unit-id to DynFlags, this is used when trying to
+        -- resolve imports.
+        let uids = map (\(iuid, (df, _uis, _targets)) -> (iuid, df)) (new : old_deps)
+
+        -- For each component, now make a new HscEnvEq which contains the
+        -- HscEnv for the hie.yaml file but the DynFlags for that component
+        --
+        -- Then look at the targets for each component and create a map
+        -- from FilePath to the HscEnv
+        let new_cache (_iuid, (df, _uis, targets)) =  do
+              let hscEnv' = hscEnv { hsc_dflags = df
+                                   , hsc_IC = (hsc_IC hscEnv) { ic_dflags = df } }
+
+              res <- newHscEnvEq hscEnv' uids
+
+              let is = importPaths df
+              ctargets <- concatMapM (targetToFile is  . targetId) targets
+              --pprTraceM "TARGETS" (ppr (map (text . show) ctargets))
+              let xs = map (,res) ctargets
+              return (xs, res)
+
+        -- New HscEnv for the component in question
+        (cs, res) <- new_cache new
+        -- Modified cache targets for everything else in the hie.yaml file
+        -- which now uses the same EPS and so on
+        cached_targets <- concatMapM (fmap fst . new_cache) old_deps
+        modifyVar_ fileToFlags $ \var -> do
+            pure $ Map.insert hieYaml (HM.fromList (cs ++ cached_targets))var
+        return res
+
+    lock <- newLock
+    cradle_lock <- newLock
+
+    -- This caches the mapping from hie.yaml + Mod.hs -> [String]
+    sessionOpts <- return $ \(hieYaml, file) -> do
+        fm <- readVar fileToFlags
+        let mv = Map.lookup hieYaml fm
+        let v = fromMaybe HM.empty mv
+        cfp <- liftIO $ canonicalizePath file
+        -- We sort so exact matches come first.
+        case HM.lookup (toNormalizedFilePath cfp) 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_lock cradle file
+                print opts
+                session (hieYaml, opts)
+    return $ \file -> liftIO $ withLock lock $ do
+        hieYaml <- cradleLoc file
+        sessionOpts (hieYaml, file)
+
+-- This function removes all the -package flags which refer to packages we
+-- are going to deal with ourselves. For example, if a executable depends
+-- on a library component, then this function will remove the library flag
+-- from the package flags for the executable
+--
+-- There are several places in GHC (for example the call to hptInstances in
+-- tcRnImports) which assume that all modules in the HPT have the same unit
+-- ID. Therefore we create a fake one and give them all the same unit id.
+removeInplacePackages :: [InstalledUnitId] -> DynFlags -> (DynFlags, [InstalledUnitId])
+removeInplacePackages us df = (df { packageFlags = ps
+                                  , thisInstalledUnitId = fake_uid }, uids)
+  where
+    (uids, ps) = partitionEithers (map go (packageFlags df))
+    fake_uid = toInstalledUnitId (stringToUnitId "fake_uid")
+    go p@(ExposePackage _ (UnitIdArg u) _) = if (toInstalledUnitId u `elem` us) then Left (toInstalledUnitId u) else Right p
+    go p = Right p
 
 -- | Memoize an IO function, with the characteristics:
 --
@@ -281,3 +448,58 @@ memoIO op = do
                 res <- onceFork $ op k
                 return (Map.insert k res mp, res)
             Just res -> return (mp, res)
+
+setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [Target])
+setOptions (ComponentOptions theOpts _) dflags = do
+    cacheDir <- liftIO $ getCacheDir theOpts
+    (dflags', targets) <- addCmdOpts theOpts dflags
+    let dflags'' =
+          -- disabled, generated directly by ghcide instead
+          flip gopt_unset Opt_WriteInterface $
+          -- disabled, generated directly by ghcide instead
+          -- also, it can confuse the interface stale check
+          dontWriteHieFiles $
+          setHiDir cacheDir $
+          setDefaultHieDir cacheDir $
+          setIgnoreInterfacePragmas $
+          setLinkerOptions $
+          disableOptimisation dflags'
+    -- initPackages parses the -package flags and
+    -- sets up the visibility for each component.
+    (final_df, _) <- liftIO $ initPackages dflags''
+--    let df'' = gopt_unset df' Opt_WarnIsError
+    return (final_df, targets)
+
+
+-- we don't want to generate object code so we compile to bytecode
+-- (HscInterpreted) which implies LinkInMemory
+-- HscInterpreted
+setLinkerOptions :: DynFlags -> DynFlags
+setLinkerOptions df = df {
+    ghcLink   = LinkInMemory
+  , hscTarget = HscNothing
+  , ghcMode = CompManager
+  }
+
+setIgnoreInterfacePragmas :: DynFlags -> DynFlags
+setIgnoreInterfacePragmas df =
+    gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges
+
+disableOptimisation :: DynFlags -> DynFlags
+disableOptimisation df = updOptLevel 0 df
+
+setHiDir :: FilePath -> DynFlags -> DynFlags
+setHiDir f d =
+    -- override user settings to avoid conflicts leading to recompilation
+    d { hiDir      = Just f}
+
+getCacheDir :: [String] -> IO FilePath
+getCacheDir opts = IO.getXdgDirectory IO.XdgCache (cacheDir </> opts_hash)
+    where
+        -- Create a unique folder per set of different GHC options, assuming that each different set of
+        -- GHC options will create incompatible interface files.
+        opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init (map B.pack opts)
+
+-- Prefix for the cache path
+cacheDir :: String
+cacheDir = "ghcide"