Preserve more information about targets (#820)

* Preserve more information about targets

* Correctly model the special target

This should prevent infinite looping on cradles that do not provide targets,
such as the hie-bios implicit cradle (no longer used)

session-loader/Development/IDE/Session.hs

@@ -34,7 +34,8 @@ import Data.Version
 import Development.IDE.Core.OfInterest
 import Development.IDE.Core.Shake
 import Development.IDE.Core.RuleTypes
-import Development.IDE.GHC.Compat
+import Development.IDE.GHC.Compat hiding (Target, TargetModule, TargetFile)
+import qualified Development.IDE.GHC.Compat as GHC
 import Development.IDE.GHC.Util
 import Development.IDE.Session.VersionCheck
 import Development.IDE.Types.Diagnostics
@@ -59,13 +60,12 @@ import System.IO
 
 import GHCi
 import DynFlags
-import HscTypes
+import HscTypes (ic_dflags, hsc_IC, hsc_dflags, hsc_NC)
 import Linker
 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.
@@ -120,7 +120,7 @@ loadSession dir = do
     let extendKnownTargets newTargets = do
           knownTargets <- forM newTargets $ \TargetDetails{..} -> do
             found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations
-            return (targetModule, found)
+            return (targetTarget, found)
           modifyVar_ knownTargetsVar $ traverseHashed $ \known -> do
             let known' = HM.unionWith (<>) known $ HM.fromList knownTargets
             when (known /= known') $
@@ -228,7 +228,7 @@ 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 optExtensions hieYaml hscEnv uids
+          let new_cache = newComponentCache logger optExtensions hieYaml _cfp 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
@@ -374,7 +374,7 @@ emptyHscEnv nc libDir = do
 
 data TargetDetails = TargetDetails
   {
-      targetModule :: !ModuleName,
+      targetTarget :: !Target,
       targetEnv :: !(IdeResult HscEnvEq),
       targetDepends :: !DependencyInfo,
       targetLocations :: ![NormalizedFilePath]
@@ -387,29 +387,18 @@ fromTargetId :: [FilePath]          -- ^ import paths
              -> DependencyInfo
              -> IO [TargetDetails]
 -- For a target module we consider all the import paths
-fromTargetId is exts (TargetModule mod) env dep = do
+fromTargetId is exts (GHC.TargetModule mod) env dep = do
     let fps = [i </> moduleNameSlashes mod -<.> ext <> boot
               | ext <- exts
               , i <- is
               , boot <- ["", "-boot"]
               ]
     locs <- mapM (fmap toNormalizedFilePath' . canonicalizePath) fps
-    return [TargetDetails mod env dep locs]
+    return [TargetDetails (TargetModule mod) env dep locs]
 -- For a 'TargetFile' we consider all the possible module names
-fromTargetId _ _ (TargetFile f _) env deps = do
+fromTargetId _ _ (GHC.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
+    return [TargetDetails (TargetFile nf) env deps [nf]]
 
 toFlagsMap :: TargetDetails -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))]
 toFlagsMap TargetDetails{..} =
@@ -424,11 +413,12 @@ newComponentCache
          :: Logger
          -> [String]       -- File extensions to consider
          -> Maybe FilePath -- Path to cradle
+         -> NormalizedFilePath -- Path to file that caused the creation of this component
          -> HscEnv
          -> [(InstalledUnitId, DynFlags)]
          -> ComponentInfo
          -> IO ( [TargetDetails], (IdeResult HscEnvEq, DependencyInfo))
-newComponentCache logger exts cradlePath hsc_env uids ci = do
+newComponentCache logger exts cradlePath cfp 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 } }
@@ -448,7 +438,7 @@ newComponentCache logger exts cradlePath hsc_env uids ci = do
     -- 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 = TargetDetails (mkModuleName "special") targetEnv targetDepends [componentFP ci]
+    let special_target = TargetDetails (TargetFile cfp) targetEnv targetDepends [componentFP ci]
     return (special_target:ctargets, res)
 
 {- Note [Avoiding bad interface files]
@@ -531,7 +521,7 @@ data RawComponentInfo = RawComponentInfo
   -- We do not want to use them unprocessed.
   , rawComponentDynFlags :: DynFlags
   -- | All targets of this components.
-  , rawComponentTargets :: [Target]
+  , rawComponentTargets :: [GHC.Target]
   -- | Filepath which caused the creation of this component
   , rawComponentFP :: NormalizedFilePath
   -- | Component Options used to load the component.
@@ -552,7 +542,7 @@ data ComponentInfo = ComponentInfo
   -- ComponentOptions.
   , _componentInternalUnits :: [InstalledUnitId]
   -- | All targets of this components.
-  , componentTargets :: [Target]
+  , componentTargets :: [GHC.Target]
   -- | Filepath which caused the creation of this component
   , componentFP :: NormalizedFilePath
   -- | Component Options used to load the component.
@@ -625,7 +615,7 @@ memoIO op = do
             Just res -> return (mp, res)
 
 -- | Throws if package flags are unsatisfiable
-setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [Target])
+setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [GHC.Target])
 setOptions (ComponentOptions theOpts compRoot _) dflags = do
     (dflags', targets) <- addCmdOpts theOpts dflags
     let dflags'' =

src/Development/IDE/Core/Rules.hs

@@ -46,7 +46,7 @@ import           Development.IDE.Core.FileExists
 import           Development.IDE.Core.FileStore        (modificationTime, getFileContents)
 import           Development.IDE.Types.Diagnostics as Diag
 import Development.IDE.Types.Location
-import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule)
+import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule, TargetModule, TargetFile)
 import Development.IDE.GHC.Util
 import Development.IDE.GHC.WithDynFlags
 import Data.Either.Extra
@@ -67,7 +67,7 @@ import qualified Data.ByteString.Char8 as BS
 import Development.IDE.Core.PositionMapping
 
 import qualified GHC.LanguageExtensions as LangExt
-import HscTypes
+import HscTypes hiding (TargetModule, TargetFile)
 import PackageConfig
 import DynFlags (gopt_set, xopt)
 import GHC.Generics(Generic)
@@ -336,7 +336,9 @@ getLocatedImportsRule =
         opt <- getIdeOptions
         let getTargetExists modName nfp
                 | isImplicitCradle = getFileExists nfp
-                | HM.member modName targets = getFileExists nfp
+                | HM.member (TargetModule modName) targets
+                || HM.member (TargetFile nfp) 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

src/Development/IDE/Core/Shake.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingStrategies #-}
 -- Copyright (c) 2019 The DAML Authors. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
 
@@ -24,7 +26,7 @@
 module Development.IDE.Core.Shake(
     IdeState, shakeExtras,
     ShakeExtras(..), getShakeExtras, getShakeExtrasRules,
-    KnownTargets, toKnownFiles,
+    KnownTargets, Target(..), toKnownFiles,
     IdeRule, IdeResult,
     GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics),
     shakeOpen, shakeShut,
@@ -165,7 +167,11 @@ data ShakeExtras = ShakeExtras
     }
 
 -- | A mapping of module name to known files
-type KnownTargets = HashMap ModuleName [NormalizedFilePath]
+type KnownTargets = HashMap Target [NormalizedFilePath]
+
+data Target = TargetModule ModuleName | TargetFile NormalizedFilePath
+  deriving ( Eq, Generic, Show )
+  deriving anyclass (Hashable, NFData)
 
 toKnownFiles :: KnownTargets -> HashSet NormalizedFilePath
 toKnownFiles = HSet.fromList . concat . HMap.elems
@@ -720,7 +726,7 @@ usesWithStale_ key files = do
         Just v -> return v
 
 newtype IdeAction a = IdeAction { runIdeActionT  :: (ReaderT ShakeExtras IO) a }
-    deriving (MonadReader ShakeExtras, MonadIO, Functor, Applicative, Monad)
+    deriving newtype (MonadReader ShakeExtras, MonadIO, Functor, Applicative, Monad)
 
 -- | IdeActions are used when we want to return a result immediately, even if it
 -- is stale Useful for UI actions like hover, completion where we don't want to
@@ -802,7 +808,7 @@ isBadDependency x
     | otherwise = False
 
 newtype Q k = Q (k, NormalizedFilePath)
-    deriving (Eq,Hashable,NFData, Generic)
+    deriving newtype (Eq, Hashable, NFData)
 
 instance Binary k => Binary (Q k) where
     put (Q (k, fp)) = put (k, fp)