Rebase ghcide changes, and match in hls branch

Author: alanz

cabal.project

@@ -16,4 +16,4 @@ package ghcide
 
 write-ghc-environment-files: never
 
-index-state: 2020-02-09T06:58:05Z
+index-state: 2020-03-03T21:14:55Z

exe/Main.hs

@@ -12,18 +12,15 @@ module Main(main) where
 
 import Arguments
 import Control.Concurrent.Extra
-import Control.DeepSeq (NFData)
 import Control.Exception
 import Control.Monad.Extra
 import Control.Monad.IO.Class
 import qualified Crypto.Hash.SHA1 as H
-import Data.Binary (Binary)
 import Data.ByteString.Base16
 import qualified Data.ByteString.Char8 as B
 import Data.Default
-import Data.Dynamic (Typeable)
+import Data.Functor ((<&>))
 import qualified Data.HashSet as HashSet
-import Data.Hashable (Hashable)
 import Data.List.Extra
 import qualified Data.Map.Strict as Map
 import Data.Maybe
@@ -46,10 +43,9 @@ import Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Location
 import Development.IDE.Types.Logger
 import Development.IDE.Types.Options
-import Development.Shake (Action, RuleResult, Rules, action, doesFileExist, need)
+import Development.Shake (Action, Rules, action, doesFileExist, doesDirectoryExist, need)
 import           DynFlags
 import GHC hiding (def)
-import GHC.Generics (Generic)
 -- import qualified GHC.Paths
 import HIE.Bios
 import HIE.Bios.Cradle
@@ -63,6 +59,7 @@ import Language.Haskell.LSP.Types (LspId(IdInt))
 import qualified Language.Haskell.LSP.Core as LSP
 import Linker
 -- import Paths_haskell_language_server
+import RuleTypes
 import qualified System.Directory.Extra as IO
 -- import System.Environment
 import System.Exit
@@ -152,7 +149,7 @@ main = do
                     , optShakeProfiling = argsShakeProfiling
                     }
             debouncer <- newAsyncDebouncer
-            initialise caps (loadGhcSessionIO >> mainRule >> pluginRules plugins >> action kick)
+            initialise caps (cradleRules >> mainRule >> pluginRules plugins >> action kick)
                 getLspId event (logger minBound) debouncer options vfs
     else do
         putStrLn $ "(haskell-language-server)Ghcide setup tester in " ++ dir ++ "."
@@ -189,7 +186,7 @@ main = do
         let options =
               (defaultIdeOptions $ return $ return . grab)
                     { optShakeProfiling = argsShakeProfiling }
-        ide <- initialise def (loadGhcSessionIO >> mainRule) (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs
+        ide <- initialise def (cradleRules >> mainRule) (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs
 
         putStrLn "\nStep 6/6: Type checking the files"
         setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath files
@@ -203,6 +200,10 @@ main = do
 
         unless (null failed) exitFailure
 
+cradleRules :: Rules ()
+cradleRules = do
+    loadGhcSessionIO
+    cradleToSession
 
 expandFiles :: [FilePath] -> IO [FilePath]
 expandFiles = concatMapM $ \x -> do
@@ -230,19 +231,6 @@ showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =
 showEvent lock e = withLock lock $ print e
 
 
--- Rule type for caching GHC sessions.
-type instance RuleResult GetHscEnv = HscEnvEq
-
-data GetHscEnv = GetHscEnv
-    { hscenvOptions :: [String]        -- componentOptions from hie-bios
-    , hscenvDependencies :: [FilePath] -- componentDependencies from hie-bios
-    }
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable GetHscEnv
-instance NFData   GetHscEnv
-instance Binary   GetHscEnv
-
-
 loadGhcSessionIO :: Rules ()
 loadGhcSessionIO =
     -- This rule is for caching the GHC session. E.g., even when the cabal file
@@ -255,6 +243,7 @@ loadGhcSessionIO =
 getComponentOptions :: Cradle a -> IO ComponentOptions
 getComponentOptions cradle = do
     let showLine s = putStrLn ("> " ++ s)
+    -- WARNING 'runCradle is very expensive and must be called as few times as possible
     cradleRes <- runCradle (cradleOptsProg cradle) showLine ""
     case cradleRes of
         CradleSuccess r -> pure r
@@ -310,8 +299,14 @@ setHiDir f d =
     -- override user settings to avoid conflicts leading to recompilation
     d { hiDir      = Just f}
 
-cradleToSession :: Maybe FilePath -> Cradle a -> Action HscEnvEq
-cradleToSession mbYaml cradle = do
+cradleToSession :: Rules ()
+cradleToSession = define $ \LoadCradle nfp -> do
+    let f = fromNormalizedFilePath nfp
+
+    -- If the path points to a directory, load the implicit cradle
+    mbYaml <- doesDirectoryExist f <&> \isDir -> if isDir then Nothing else Just f
+    cradle <- liftIO $  maybe (loadImplicitCradle $ addTrailingPathSeparator f) loadCradle mbYaml
+
     cmpOpts <- liftIO $ getComponentOptions cradle
     let opts = componentOptions cmpOpts
         deps = componentDependencies cmpOpts
@@ -321,7 +316,7 @@ cradleToSession mbYaml cradle = do
                   _ -> deps
     existingDeps <- filterM doesFileExist deps'
     need existingDeps
-    useNoFile_ $ GetHscEnv opts deps
+    ([],) . pure <$> useNoFile_ (GetHscEnv opts deps)
 
 
 loadSession :: FilePath -> Action (FilePath -> Action HscEnvEq)
@@ -335,8 +330,9 @@ loadSession dir = liftIO $ do
         return $ normalise <$> res'
     let session :: Maybe FilePath -> Action HscEnvEq
         session file = do
-          c <- liftIO $ maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle file
-          cradleToSession file c
+          -- 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)
 
 

exe/RuleTypes.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeFamilies #-}
+module RuleTypes (GetHscEnv(..), LoadCradle(..)) where
+
+import Control.DeepSeq
+import Data.Binary
+import Data.Hashable (Hashable)
+import Development.Shake
+import Development.IDE.GHC.Util
+import Data.Typeable (Typeable)
+import GHC.Generics (Generic)
+
+-- Rule type for caching GHC sessions.
+type instance RuleResult GetHscEnv = HscEnvEq
+
+data GetHscEnv = GetHscEnv
+    { hscenvOptions :: [String]        -- componentOptions from hie-bios
+    , hscenvDependencies :: [FilePath] -- componentDependencies from hie-bios
+    }
+    deriving (Eq, Show, Typeable, Generic)
+
+instance Hashable GetHscEnv
+instance NFData   GetHscEnv
+instance Binary   GetHscEnv
+
+-- Rule type for caching cradle loading
+type instance RuleResult LoadCradle = HscEnvEq
+
+data LoadCradle = LoadCradle
+    deriving (Eq, Show, Typeable, Generic)
+
+instance Hashable LoadCradle
+instance NFData   LoadCradle
+instance Binary   LoadCradle

ghcide

@@ -92,6 +92,7 @@ executable haskell-language-server
   other-modules:
       Arguments
       Paths_haskell_language_server
+      RuleTypes
   autogen-modules:
       Paths_haskell_language_server
   ghc-options: