diff --git a/exe/Main.hs b/exe/Main.hs index aa574b4b8..48f7b09bb 100644 --- a/exe/Main.hs +++ b/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,25 +170,52 @@ 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 @@ -201,11 +223,48 @@ loadSession dir = do -- 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: -- diff --git a/ghcide.cabal b/ghcide.cabal index 2c98d2dd2..072582561 100644 --- a/ghcide.cabal +++ b/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.* diff --git a/hie.yaml b/hie.yaml index 1f9f2f0d7..1f5848879 100644 --- a/hie.yaml +++ b/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" diff --git a/stack.yaml b/stack.yaml index 53596f176..4e92bc121 100644 --- a/stack.yaml +++ b/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]