{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DuplicateRecordFields #-}
module Development.IDE.Core.Rules(
IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),
Priority(..),
priorityTypeCheck,
priorityGenerateCore,
priorityFilesOfInterest,
runAction, useE, useNoFileE, usesE,
toIdeResult, defineNoFile,
mainRule,
getGhcCore,
getAtPoint,
getDefinition,
getDependencies,
getParsedModule,
fileFromParsedModule,
) where
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Development.IDE.Core.Compile
import Development.IDE.Types.Options
import Development.IDE.Spans.Calculate
import Development.IDE.Import.DependencyInformation
import Development.IDE.Import.FindImports
import Development.IDE.Core.FileStore
import Development.IDE.Types.Diagnostics
import Development.IDE.Types.Location
import Development.IDE.GHC.Util
import Data.Coerce
import Data.Either.Extra
import Data.Maybe
import Data.Foldable
import qualified Data.IntMap.Strict as IntMap
import qualified Data.IntSet as IntSet
import Data.List
import qualified Data.Set as Set
import qualified Data.Text as T
import Development.IDE.GHC.Error
import Development.Shake hiding (Diagnostic)
import Development.IDE.Core.RuleTypes
import GHC hiding (parseModule, typecheckModule)
import Development.IDE.GHC.Compat
import UniqSupply
import NameCache
import HscTypes
import GHC.Generics(Generic)
import qualified Development.IDE.Spans.AtPoint as AtPoint
import Development.IDE.Core.Service
import Development.IDE.Core.Shake
import Development.Shake.Classes
toIdeResult :: Either [FileDiagnostic] v -> IdeResult v
toIdeResult = either (, Nothing) (([],) . Just)
useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v
useE k = MaybeT . use k
useNoFileE :: IdeRule k v => k -> MaybeT Action v
useNoFileE k = useE k ""
usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT Action [v]
usesE k = MaybeT . fmap sequence . uses k
defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()
defineNoFile f = define $ \k file -> do
if file == "" then do res <- f k; return ([], Just res) else
fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"
getGhcCore :: NormalizedFilePath -> Action (Maybe [CoreModule])
getGhcCore file = runMaybeT $ do
files <- transitiveModuleDeps <$> useE GetDependencies file
pms <- usesE GetParsedModule $ files ++ [file]
usesE GenerateCore $ map fileFromParsedModule pms
getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath])
getDependencies file = fmap transitiveModuleDeps <$> use GetDependencies file
getAtPoint :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text]))
getAtPoint file pos = fmap join $ runMaybeT $ do
opts <- lift getIdeOptions
files <- transitiveModuleDeps <$> useE GetDependencies file
tms <- usesE TypeCheck (file : files)
spans <- useE GetSpanInfo file
return $ AtPoint.atPoint opts (map tmrModule tms) spans pos
getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)
getDefinition file pos = fmap join $ runMaybeT $ do
spans <- useE GetSpanInfo file
pkgState <- hscEnv <$> useE GhcSession file
opts <- lift getIdeOptions
let getHieFile x = useNoFile (GetHieFile x)
lift $ AtPoint.gotoDefinition getHieFile opts pkgState spans pos
getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)
getParsedModule file = use GetParsedModule file
priorityTypeCheck :: Priority
priorityTypeCheck = Priority 0
priorityGenerateCore :: Priority
priorityGenerateCore = Priority (-1)
priorityFilesOfInterest :: Priority
priorityFilesOfInterest = Priority (-2)
getParsedModuleRule :: Rules ()
getParsedModuleRule =
define $ \GetParsedModule file -> do
(_, contents) <- getFileContents file
packageState <- hscEnv <$> use_ GhcSession file
opt <- getIdeOptions
liftIO $ parseModule opt packageState (fromNormalizedFilePath file) contents
getLocatedImportsRule :: Rules ()
getLocatedImportsRule =
define $ \GetLocatedImports file -> do
pm <- use_ GetParsedModule file
let ms = pm_mod_summary pm
let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]
env <- hscEnv <$> use_ GhcSession file
let dflags = addRelativeImport file pm $ hsc_dflags env
opt <- getIdeOptions
(diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do
diagOrImp <- locateModule dflags (optExtensions opt) getFileExists modName mbPkgName isSource
case diagOrImp of
Left diags -> pure (diags, Left (modName, Nothing))
Right (FileImport path) -> pure ([], Left (modName, Just path))
Right (PackageImport pkgId) -> liftIO $ do
diagsOrPkgDeps <- computePackageDeps env pkgId
case diagsOrPkgDeps of
Left diags -> pure (diags, Right Nothing)
Right pkgIds -> pure ([], Right $ Just $ pkgId : pkgIds)
let (moduleImports, pkgImports) = partitionEithers imports'
case sequence pkgImports of
Nothing -> pure (concat diags, Nothing)
Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports))
rawDependencyInformation :: NormalizedFilePath -> Action RawDependencyInformation
rawDependencyInformation f = do
let (initialId, initialMap) = getPathId f emptyPathIdMap
go (IntSet.singleton $ getFilePathId initialId)
(RawDependencyInformation IntMap.empty initialMap)
where
go fs rawDepInfo =
case IntSet.minView fs of
Nothing -> pure rawDepInfo
Just (f, fs) -> do
let fId = FilePathId f
importsOrErr <- use GetLocatedImports $ idToPath (rawPathIdMap rawDepInfo) fId
case importsOrErr of
Nothing ->
let rawDepInfo' = insertImport fId (Left ModuleParseError) rawDepInfo
in go fs rawDepInfo'
Just (modImports, pkgImports) -> do
let f :: PathIdMap -> (a, Maybe NormalizedFilePath) -> (PathIdMap, (a, Maybe FilePathId))
f pathMap (imp, mbPath) = case mbPath of
Nothing -> (pathMap, (imp, Nothing))
Just path ->
let (pathId, pathMap') = getPathId path pathMap
in (pathMap', (imp, Just pathId))
let (pathIdMap, modImports') = mapAccumL f (rawPathIdMap rawDepInfo) modImports
let newFiles =
IntSet.fromList (coerce $ mapMaybe snd modImports')
IntSet.\\ IntMap.keysSet (rawImports rawDepInfo)
let rawDepInfo' = insertImport fId (Right $ ModuleImports modImports' pkgImports) rawDepInfo
go (newFiles `IntSet.union` fs) (rawDepInfo' { rawPathIdMap = pathIdMap })
getDependencyInformationRule :: Rules ()
getDependencyInformationRule =
define $ \GetDependencyInformation file -> do
rawDepInfo <- rawDependencyInformation file
pure ([], Just $ processDependencyInformation rawDepInfo)
reportImportCyclesRule :: Rules ()
reportImportCyclesRule =
define $ \ReportImportCycles file -> fmap (\errs -> if null errs then ([], Just ()) else (errs, Nothing)) $ do
DependencyInformation{..} <- use_ GetDependencyInformation file
let fileId = pathToId depPathIdMap file
case IntMap.lookup (getFilePathId fileId) depErrorNodes of
Nothing -> pure []
Just errs -> do
let cycles = mapMaybe (cycleErrorInFile fileId) (toList errs)
forM cycles $ \(imp, files) -> do
modNames <- forM files $ \fileId -> do
let file = idToPath depPathIdMap fileId
getModuleName file
pure $ toDiag imp $ sort modNames
where cycleErrorInFile f (PartOfCycle imp fs)
| f `elem` fs = Just (imp, fs)
cycleErrorInFile _ _ = Nothing
toDiag imp mods = (fp ,) $ Diagnostic
{ _range = (_range :: Location -> Range) loc
, _severity = Just DsError
, _source = Just "Import cycle detection"
, _message = "Cyclic module dependency between " <> showCycle mods
, _code = Nothing
, _relatedInformation = Nothing
}
where loc = srcSpanToLocation (getLoc imp)
fp = toNormalizedFilePath $ srcSpanToFilename (getLoc imp)
getModuleName file = do
pm <- use_ GetParsedModule file
pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)
showCycle mods = T.intercalate ", " (map T.pack mods)
getDependenciesRule :: Rules ()
getDependenciesRule =
define $ \GetDependencies file -> do
depInfo@DependencyInformation{..} <- use_ GetDependencyInformation file
let allFiles = reachableModules depInfo
_ <- uses_ ReportImportCycles allFiles
return ([], transitiveDeps depInfo file)
getSpanInfoRule :: Rules ()
getSpanInfoRule =
define $ \GetSpanInfo file -> do
tc <- use_ TypeCheck file
(fileImports, _) <- use_ GetLocatedImports file
packageState <- hscEnv <$> use_ GhcSession file
x <- liftIO $ getSrcSpanInfos packageState fileImports tc
return ([], Just x)
typeCheckRule :: Rules ()
typeCheckRule =
define $ \TypeCheck file -> do
pm <- use_ GetParsedModule file
deps <- use_ GetDependencies file
tms <- uses_ TypeCheck (transitiveModuleDeps deps)
setPriority priorityTypeCheck
packageState <- hscEnv <$> use_ GhcSession file
IdeOptions{ optDefer = defer} <- getIdeOptions
liftIO $ typecheckModule defer packageState tms pm
generateCoreRule :: Rules ()
generateCoreRule =
define $ \GenerateCore file -> do
deps <- use_ GetDependencies file
(tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)
setPriority priorityGenerateCore
packageState <- hscEnv <$> use_ GhcSession file
liftIO $ compileModule packageState tms tm
type instance RuleResult GhcSessionIO = GhcSessionFun
data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic)
instance Hashable GhcSessionIO
instance NFData GhcSessionIO
newtype GhcSessionFun = GhcSessionFun (FilePath -> Action HscEnvEq)
instance Show GhcSessionFun where show _ = "GhcSessionFun"
instance NFData GhcSessionFun where rnf !_ = ()
loadGhcSession :: Rules ()
loadGhcSession = do
defineNoFile $ \GhcSessionIO -> do
opts <- getIdeOptions
liftIO $ GhcSessionFun <$> optGhcSession opts
define $ \GhcSession file -> do
GhcSessionFun fun <- useNoFile_ GhcSessionIO
val <- fun $ fromNormalizedFilePath file
return ([], Just val)
getHieFileRule :: Rules ()
getHieFileRule =
defineNoFile $ \(GetHieFile f) -> do
u <- liftIO $ mkSplitUniqSupply 'a'
let nameCache = initNameCache u []
liftIO $ fmap (hie_file_result . fst) $ readHieFile nameCache f
mainRule :: Rules ()
mainRule = do
getParsedModuleRule
getLocatedImportsRule
getDependencyInformationRule
reportImportCyclesRule
getDependenciesRule
typeCheckRule
getSpanInfoRule
generateCoreRule
loadGhcSession
getHieFileRule
fileFromParsedModule :: ParsedModule -> NormalizedFilePath
fileFromParsedModule = toNormalizedFilePath . ms_hspp_file . pm_mod_summary