{-# 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,
getAtPoint,
getDefinition,
getDependencies,
getParsedModule,
generateCore,
) where
import Fingerprint
import Data.Binary
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.FileExists
import Development.IDE.Core.FileStore (getFileContents)
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 Development.IDE.Spans.Type
import GHC hiding (parseModule, typecheckModule)
import qualified GHC.LanguageExtensions as LangExt
import Development.IDE.GHC.Compat (hie_file_result, readHieFile)
import UniqSupply
import NameCache
import HscTypes
import DynFlags (xopt)
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"
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
spans <- useE GetSpanInfo file
return $ AtPoint.atPoint opts spans pos
getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)
getDefinition file pos = fmap join $ runMaybeT $ do
opts <- lift getIdeOptions
spans <- useE GetSpanInfo file
pkgState <- hscEnv <$> useE GhcSession file
let getHieFile x = useNoFile (GetHieFile x)
lift $ AtPoint.gotoDefinition getHieFile opts pkgState (spansExprs 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 =
defineEarlyCutoff $ \GetParsedModule file -> do
(_, contents) <- getFileContents file
packageState <- hscEnv <$> use_ GhcSession file
opt <- getIdeOptions
(diag, res) <- liftIO $ parseModule opt packageState (fromNormalizedFilePath file) (fmap textToStringBuffer contents)
case res of
Nothing -> pure (Nothing, (diag, Nothing))
Just (contents, modu) -> do
mbFingerprint <- if isNothing $ optShakeFiles opt
then pure Nothing
else liftIO $ Just . fingerprintToBS <$> fingerprintFromStringBuffer contents
pure (mbFingerprint, (diag, Just modu))
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 , ShowDiag , ) $ 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 =
defineEarlyCutoff $ \GetDependencies file -> do
depInfo@DependencyInformation{..} <- use_ GetDependencyInformation file
let allFiles = reachableModules depInfo
_ <- uses_ ReportImportCycles allFiles
opts <- getIdeOptions
let mbFingerprints = map (fingerprintString . fromNormalizedFilePath) allFiles <$ optShakeFiles opts
return (fingerprintToBS . fingerprintFingerprints <$> mbFingerprints, ([], transitiveDeps depInfo file))
getSpanInfoRule :: Rules ()
getSpanInfoRule =
define $ \GetSpanInfo file -> do
tc <- use_ TypeCheck file
deps <- maybe (TransitiveDependencies [] []) fst <$> useWithStale GetDependencies file
tms <- mapMaybe (fmap fst) <$> usesWithStale TypeCheck (transitiveModuleDeps deps)
(fileImports, _) <- use_ GetLocatedImports file
packageState <- hscEnv <$> use_ GhcSession file
x <- liftIO $ getSrcSpanInfos packageState fileImports tc tms
return ([], Just x)
typeCheckRule :: Rules ()
typeCheckRule =
define $ \TypeCheck file -> do
pm <- use_ GetParsedModule file
deps <- use_ GetDependencies file
packageState <- hscEnv <$> use_ GhcSession file
let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph packageState
file_uses_th_qq = uses_th_qq $ ms_hspp_opts (pm_mod_summary pm)
any_uses_th_qq = graph_needs_th_qq || file_uses_th_qq
tms <- if any_uses_th_qq
then do
bytecodes <- uses_ GenerateByteCode (transitiveModuleDeps deps)
tmrs <- uses_ TypeCheck (transitiveModuleDeps deps)
pure (zipWith addByteCode bytecodes tmrs)
else uses_ TypeCheck (transitiveModuleDeps deps)
setPriority priorityTypeCheck
IdeOptions{ optDefer = defer} <- getIdeOptions
liftIO $ typecheckModule defer packageState tms pm
where
uses_th_qq dflags = xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
addByteCode :: Linkable -> TcModuleResult -> TcModuleResult
addByteCode lm tmr = tmr { tmrModInfo = (tmrModInfo tmr) { hm_linkable = Just lm } }
generateCore :: NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails))
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
generateCoreRule :: Rules ()
generateCoreRule =
define $ \GenerateCore -> generateCore
generateByteCodeRule :: Rules ()
generateByteCodeRule =
define $ \GenerateByteCode file -> do
deps <- use_ GetDependencies file
(tm : tms) <- uses_ TypeCheck (file: transitiveModuleDeps deps)
session <- hscEnv <$> use_ GhcSession file
(_, guts, _) <- use_ GenerateCore file
liftIO $ generateByteCode session tms tm guts
type instance RuleResult GhcSessionIO = GhcSessionFun
data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic)
instance Hashable GhcSessionIO
instance NFData GhcSessionIO
instance Binary 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
defineEarlyCutoff $ \GhcSession file -> do
GhcSessionFun fun <- useNoFile_ GhcSessionIO
val <- fun $ fromNormalizedFilePath file
opts <- getIdeOptions
return ("" <$ optShakeFiles opts, ([], 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
generateByteCodeRule
loadGhcSession
getHieFileRule