Import paths are relative to cradle (#781)

* Import paths are relative to cradle

I noticed ghcide HEAD was broken on the ghcide submodule of the hls repo.

* remove unused

* Fix comment placement

* Special case the implicit cradle

The implicit cradle comes without import paths, so we need to preserve the old
logic that synthetised them from the current module

* Hlint

* Fix timing issue: update known files before restarting the session

Also, DO NOT filter out missing targets

* Use --verbose when running tests

* Log test outputs on 3rd attempt

* Fall back to filtering known files

* hlint

* Upgrade KnownFiles to KnownTargets

* Use KnownTargets to filter modules, not module paths

* Fix test cradle

* Increase pauses in flaky test

* remove no longer needed check

* Disable ansi color codes in CI

* Disable flaky test

Author: pepeiborra

.azure/linux-stack.yml

@@ -45,7 +45,7 @@ jobs:
     displayName: 'stack build --only-dependencies'
   - bash: |
       export PATH=/opt/cabal/bin:$PATH
-      stack test --ghc-options=-Werror  --stack-yaml=$STACK_YAML || stack test --ghc-options=-Werror --stack-yaml=$STACK_YAML|| stack test --ghc-options=-Werror --stack-yaml=$STACK_YAML
+      stack test --ghc-options=-Werror  --stack-yaml=$STACK_YAML || stack test --ghc-options=-Werror --stack-yaml=$STACK_YAML|| LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true stack test --ghc-options=-Werror --stack-yaml=$STACK_YAML
     # ghcide stack tests are flaky, see https://github.com/digital-asset/daml/issues/2606.
     displayName: 'stack test --ghc-options=-Werror'
   - bash: |

session-loader/Development/IDE/Session.hs

@@ -25,7 +25,6 @@ import Data.Bifunctor
 import qualified Data.ByteString.Base16 as B16
 import Data.Either.Extra
 import Data.Function
-import qualified Data.HashSet as HashSet
 import Data.Hashable
 import Data.List
 import Data.IORef
@@ -65,6 +64,7 @@ import Module
 import NameCache
 import Packages
 import Control.Exception (evaluate)
+import Data.Char
 
 -- | Given a root directory, return a Shake 'Action' which setups an
 -- 'IdeGhcSession' given a file.
@@ -104,14 +104,28 @@ loadSession dir = do
 
   return $ do
     extras@ShakeExtras{logger, eventer, restartShakeSession,
-                       withIndefiniteProgress, ideNc, knownFilesVar
+                       withIndefiniteProgress, ideNc, knownTargetsVar
                       } <- getShakeExtras
 
     IdeOptions{ optTesting = IdeTesting optTesting
               , optCheckProject = CheckProject checkProject
               , optCustomDynFlags
               } <- getIdeOptions
 
+        -- populate the knownTargetsVar with all the
+        -- files in the project so that `knownFiles` can learn about them and
+        -- we can generate a complete module graph
+    let extendKnownTargets newTargets = do
+          knownTargets <- forM newTargets $ \TargetDetails{..} -> do
+            found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations
+            return (targetModule, found)
+          modifyVar_ knownTargetsVar $ traverseHashed $ \known -> do
+            let known' = HM.unionWith (<>) known $ HM.fromList knownTargets
+            when (known /= known') $
+                logDebug logger $ "Known files updated: " <>
+                    T.pack(show $ (HM.map . map) fromNormalizedFilePath known')
+            evaluate known'
+
     -- 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
@@ -212,20 +226,26 @@ loadSession dir = do
 
           -- New HscEnv for the component in question, returns the new HscEnvEq and
           -- a mapping from FilePath to the newly created HscEnvEq.
-          let new_cache = newComponentCache logger isImplicit hscEnv uids
-              isImplicit = isNothing hieYaml
+          let new_cache = newComponentCache logger hieYaml hscEnv uids
           (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
+
+          let all_targets = cs ++ cached_targets
+
           modifyVar_ fileToFlags $ \var -> do
-              pure $ Map.insert hieYaml (HM.fromList (cs ++ cached_targets)) var
+              pure $ Map.insert hieYaml (HM.fromList (concatMap toFlagsMap all_targets)) var
+
+          extendKnownTargets all_targets
 
           -- Invalidate all the existing GhcSession build nodes by restarting the Shake session
           invalidateShakeCache
           restartShakeSession [kick]
 
-          return (map fst cs ++ map fst cached_targets, second Map.keys res)
+          let resultCachedTargets = concatMap targetLocations all_targets
+
+          return (resultCachedTargets, second Map.keys res)
 
     let consultCradle :: Maybe FilePath -> FilePath -> IO ([NormalizedFilePath], (IdeResult HscEnvEq, [FilePath]))
         consultCradle hieYaml cfp = do
@@ -299,14 +319,10 @@ loadSession dir = do
         void $ wait as
         as <- async $ getOptions file
         return (fmap snd as, wait as)
-      unless (null cs) $
+      unless (null cs) $ do
+        cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) cs
         -- Typecheck all files in the project on startup
         void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do
-          cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) cs
-          -- populate the knownFilesVar with all the
-          -- files in the project so that `knownFiles` can learn about them and
-          -- we can generate a complete module graph
-          liftIO $ modifyVar_ knownFilesVar $ traverseHashed $ pure . HashSet.union (HashSet.fromList cfps')
           when checkProject $ do
             mmt <- uses GetModificationTime cfps'
             let cs_exist = catMaybes (zipWith (<$) cfps' mmt)
@@ -320,6 +336,7 @@ loadSession dir = do
 -- | Run the specific cradle on a specific FilePath via hie-bios.
 -- This then builds dependencies or whatever based on the cradle, gets the
 -- GHC options/dynflags needed for the session and the GHC library directory
+
 cradleToOptsAndLibDir :: Show a => Cradle a -> FilePath
                       -> IO (Either [CradleError] (ComponentOptions, FilePath))
 cradleToOptsAndLibDir cradle file = do
@@ -349,52 +366,79 @@ emptyHscEnv nc libDir = do
     initDynLinker env
     pure $ setNameCache nc 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
+data TargetDetails = TargetDetails
+  {
+      targetModule :: !ModuleName,
+      targetEnv :: !(IdeResult HscEnvEq),
+      targetDepends :: !DependencyInfo,
+      targetLocations :: ![NormalizedFilePath]
+  }
+
+fromTargetId :: [FilePath]          -- ^ import paths
+             -> TargetId
+             -> IdeResult HscEnvEq
+             -> DependencyInfo
+             -> IO [TargetDetails]
+-- For a target module we consider all the import paths
+fromTargetId is (TargetModule mod) env dep = 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']
+    locs <- mapM (fmap toNormalizedFilePath' . canonicalizePath) fps
+    return [TargetDetails mod env dep locs]
+-- For a 'TargetFile' we consider all the possible module names
+fromTargetId _ (TargetFile f _) env deps = do
+    nf <- toNormalizedFilePath' <$> canonicalizePath f
+    return [TargetDetails m env deps [nf] | m <- moduleNames f]
+
+-- >>> moduleNames "src/A/B.hs"
+-- [A.B,B]
+moduleNames :: FilePath -> [ModuleName]
+moduleNames f = map (mkModuleName .intercalate ".") $ init $ tails nameSegments
+    where
+        nameSegments = reverse
+                     $ takeWhile (isUpper . head)
+                     $ reverse
+                     $ splitDirectories
+                     $ dropExtension f
+
+toFlagsMap :: TargetDetails -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))]
+toFlagsMap TargetDetails{..} =
+    [ (l, (targetEnv, targetDepends)) | l <-  targetLocations]
+
 
 setNameCache :: IORef NameCache -> HscEnv -> HscEnv
 setNameCache nc hsc = hsc { hsc_NC = nc }
 
-
 -- | Create a mapping from FilePaths to HscEnvEqs
 newComponentCache
          :: Logger
-         -> Bool    -- ^ Is this for an implicit/crappy cradle
+         -> Maybe FilePath -- Path to cradle
          -> HscEnv
          -> [(InstalledUnitId, DynFlags)]
          -> ComponentInfo
-         -> IO ([(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))], (IdeResult HscEnvEq, DependencyInfo))
-newComponentCache logger isImplicit hsc_env uids ci = do
+         -> IO ( [TargetDetails], (IdeResult HscEnvEq, DependencyInfo))
+newComponentCache logger cradlePath hsc_env uids ci = do
     let df = componentDynFlags ci
     let hscEnv' = hsc_env { hsc_dflags = df
                           , hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } }
 
-    let newFunc = if isImplicit then newHscEnvEqPreserveImportPaths else newHscEnvEq
+    let newFunc = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath
     henv <- newFunc hscEnv' uids
-    let res = (([], Just henv), componentDependencyInfo ci)
+    let targetEnv = ([], Just henv)
+        targetDepends = componentDependencyInfo ci
+        res = (targetEnv, targetDepends)
     logDebug logger ("New Component Cache HscEnvEq: " <> T.pack (show res))
 
-    let is = importPaths df
-    ctargets <- concatMapM (targetToFile is  . targetId) (componentTargets ci)
+    let mk t = fromTargetId (importPaths df) (targetId t) targetEnv targetDepends
+    ctargets <- concatMapM mk (componentTargets ci)
+
     -- A special target for the file which caused this wonderful
     -- component to be created. In case the cradle doesn't list all the targets for
     -- the component, in which case things will be horribly broken anyway.
     -- Otherwise, we will immediately attempt to reload this module which
     -- causes an infinite loop and high CPU usage.
-    let special_target = (componentFP ci, res)
-    let xs = map (,res) ctargets
-    return (special_target:xs, res)
+    let special_target = TargetDetails (mkModuleName "special") targetEnv targetDepends [componentFP ci]
+    return (special_target:ctargets, res)
 
 {- Note [Avoiding bad interface files]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

src/Development/IDE/Core/FileStore.hs

@@ -252,15 +252,13 @@ typecheckParents state nfp = void $ shakeEnqueue (shakeExtras state) parents
 
 typecheckParentsAction :: NormalizedFilePath -> Action ()
 typecheckParentsAction nfp = do
-    fs <- useNoFile_ GetKnownFiles
-    unless (null fs) $ do
-      revs <- reverseDependencies nfp <$> useNoFile_ GetModuleGraph
-      logger <- logger <$> getShakeExtras
-      let log = L.logInfo logger . T.pack
-      liftIO $ do
-        (log $ "Typechecking reverse dependencies for" ++ show nfp ++ ": " ++ show revs)
-          `catch` \(e :: SomeException) -> log (show e)
-      () <$ uses GetModIface revs
+    revs <- reverseDependencies nfp <$> useNoFile_ GetModuleGraph
+    logger <- logger <$> getShakeExtras
+    let log = L.logInfo logger . T.pack
+    liftIO $ do
+      (log $ "Typechecking reverse dependencies for" ++ show nfp ++ ": " ++ show revs)
+        `catch` \(e :: SomeException) -> log (show e)
+    () <$ uses GetModIface revs
 
 -- | Note that some buffer somewhere has been modified, but don't say what.
 --   Only valid if the virtual file system was initialised by LSP, as that

src/Development/IDE/Core/RuleTypes.hs

@@ -16,10 +16,10 @@ import Data.Binary
 import           Development.IDE.Import.DependencyInformation
 import Development.IDE.GHC.Compat
 import Development.IDE.GHC.Util
+import Development.IDE.Core.Shake (KnownTargets)
 import           Data.Hashable
 import           Data.Typeable
 import qualified Data.Set as S
-import qualified Data.HashSet                             as HS
 import           Development.Shake
 import           GHC.Generics                             (Generic)
 
@@ -29,7 +29,6 @@ import HscTypes (hm_iface, CgGuts, Linkable, HomeModInfo, ModDetails)
 import           Development.IDE.Spans.Type
 import           Development.IDE.Import.FindImports (ArtifactsLocation)
 import Data.ByteString (ByteString)
-import Language.Haskell.LSP.Types (NormalizedFilePath)
 
 
 -- NOTATION
@@ -50,12 +49,12 @@ type instance RuleResult GetDependencies = TransitiveDependencies
 
 type instance RuleResult GetModuleGraph = DependencyInformation
 
-data GetKnownFiles = GetKnownFiles
+data GetKnownTargets = GetKnownTargets
   deriving (Show, Generic, Eq, Ord)
-instance Hashable GetKnownFiles
-instance NFData   GetKnownFiles
-instance Binary   GetKnownFiles
-type instance RuleResult GetKnownFiles = HS.HashSet NormalizedFilePath
+instance Hashable GetKnownTargets
+instance NFData   GetKnownTargets
+instance Binary   GetKnownTargets
+type instance RuleResult GetKnownTargets = KnownTargets
 
 -- | Contains the typechecked module and the OrigNameCache entry for
 -- that module.

src/Development/IDE/Core/Rules.hs

@@ -90,6 +90,7 @@ import qualified HeaderInfo as Hdr
 import Data.Time (UTCTime(..))
 import Data.Hashable
 import qualified Data.HashSet as HashSet
+import qualified Data.HashMap.Strict as HM
 
 -- | This is useful for rules to convert rules that can only produce errors or
 -- a result into the more general IdeResult type that supports producing
@@ -322,15 +323,20 @@ getLocatedImportsRule :: Rules ()
 getLocatedImportsRule =
     define $ \GetLocatedImports file -> do
         ms <- use_ GetModSummaryWithoutTimestamps file
-        targets <- useNoFile_ GetKnownFiles
+        targets <- useNoFile_ GetKnownTargets
         let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]
         env_eq <- use_ GhcSession file
         let env = hscEnvWithImportPaths env_eq
         let import_dirs = deps env_eq
-        let dflags = addRelativeImport file (moduleName $ ms_mod ms) $ hsc_dflags env
+        let dflags = hsc_dflags env
+            isImplicitCradle = isNothing $ envImportPaths env_eq
+        dflags <- return $ if isImplicitCradle
+                    then addRelativeImport file (moduleName $ ms_mod ms) dflags
+                    else dflags
         opt <- getIdeOptions
-        let getTargetExists nfp
-                | HashSet.null targets || nfp `HashSet.member` targets = getFileExists nfp
+        let getTargetExists modName nfp
+                | isImplicitCradle = getFileExists nfp
+                | HM.member modName targets = getFileExists nfp
                 | otherwise = return False
         (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do
             diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getTargetExists modName mbPkgName isSource
@@ -532,14 +538,14 @@ typeCheckRule = define $ \TypeCheck file -> do
     typeCheckRuleDefinition hsc pm isFoi (Just source)
 
 knownFilesRule :: Rules ()
-knownFilesRule = defineEarlyCutOffNoFile $ \GetKnownFiles -> do
+knownFilesRule = defineEarlyCutOffNoFile $ \GetKnownTargets -> do
   alwaysRerun
-  fs <- knownFiles
+  fs <- knownTargets
   pure (BS.pack (show $ hash fs), unhashed fs)
 
 getModuleGraphRule :: Rules ()
 getModuleGraphRule = defineNoFile $ \GetModuleGraph -> do
-  fs <- useNoFile_ GetKnownFiles
+  fs <- toKnownFiles <$> useNoFile_ GetKnownTargets
   rawDepInfo <- rawDependencyInformation (HashSet.toList fs)
   pure $ processDependencyInformation rawDepInfo
 
@@ -683,7 +689,7 @@ ghcSessionDepsDefinition file = do
             setupFinderCache (map hirModSummary ifaces)
             mapM_ (uncurry loadDepModule) inLoadOrder
 
-        res <- liftIO $ newHscEnvEq session' []
+        res <- liftIO $ newHscEnvEq "" session' []
         return ([], Just res)
  where
   unpack HiFileResult{..} bc = (hirModIface, bc)