-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0

{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE TypeFamilies          #-}

-- | A Shake implementation of the compiler service, built
--   using the "Shaker" abstraction layer for in-memory use.
--
module Development.IDE.Core.Rules(
    -- * Types
    IdeState, GetParsedModule(..), TransitiveDependencies(..),
    Priority(..), GhcSessionIO(..), GetClientSettings(..),
    -- * Functions
    priorityTypeCheck,
    priorityGenerateCore,
    priorityFilesOfInterest,
    runAction,
    toIdeResult,
    defineNoFile,
    defineEarlyCutOffNoFile,
    mainRule,
    RulesConfig(..),
    getParsedModule,
    getParsedModuleWithComments,
    getClientConfigAction,
    usePropertyAction,
    getHieFile,
    -- * Rules
    CompiledLinkables(..),
    getParsedModuleRule,
    getParsedModuleWithCommentsRule,
    getLocatedImportsRule,
    reportImportCyclesRule,
    typeCheckRule,
    getDocMapRule,
    loadGhcSession,
    getModIfaceFromDiskRule,
    getModIfaceRule,
    getModSummaryRule,
    getModuleGraphRule,
    knownFilesRule,
    getClientSettingsRule,
    getHieAstsRule,
    getBindingsRule,
    needsCompilationRule,
    computeLinkableTypeForDynFlags,
    generateCoreRule,
    getImportMapRule,
    regenerateHiFile,
    ghcSessionDepsDefinition,
    getParsedModuleDefinition,
    typeCheckRuleDefinition,
    getRebuildCount,
    getSourceFileSource,
    currentLinkables,
    GhcSessionDepsConfig(..),
    Log(..),
    DisplayTHWarning(..),
    ) where

import           Prelude                                      hiding (mod)
import           Control.Applicative
import           Control.Concurrent.Async                     (concurrently)
import           Control.Concurrent.Strict
import           Control.DeepSeq
import           Control.Exception.Safe
import           Control.Exception                            (evaluate)
import           Control.Monad.Extra                          hiding (msum)
import           Control.Monad.Reader                         hiding (msum)
import           Control.Monad.State                          hiding (msum)
import           Control.Monad.Trans.Except                   (ExceptT, except,
                                                               runExceptT)
import           Control.Monad.Trans.Maybe
import           Data.Aeson                                   (toJSON)
import qualified Data.Binary                                  as B
import qualified Data.ByteString                              as BS
import qualified Data.ByteString.Lazy                         as LBS
import           Data.Coerce
import           Data.Foldable                                hiding (msum)
import qualified Data.HashMap.Strict                          as HM
import qualified Data.HashSet                                 as HashSet
import           Data.Hashable
import           Data.IORef
import           Control.Concurrent.STM.TVar
import           Data.IntMap.Strict                           (IntMap)
import qualified Data.IntMap.Strict                           as IntMap
import           Data.List
import           Data.List.Extra                              (nubOrdOn)
import qualified Data.Map                                     as M
import           Data.Maybe
import           Data.Proxy
import qualified Data.Text.Utf16.Rope                         as Rope
import qualified Data.Set                                     as Set
import qualified Data.Text                                    as T
import qualified Data.Text.Encoding                           as T
import           Data.Time                                    (UTCTime (..))
import           Data.Tuple.Extra
import           Data.Typeable                                (cast)
import           Development.IDE.Core.Compile
import           Development.IDE.Core.FileExists hiding (LogShake, Log)
import           Development.IDE.Core.FileStore               (getFileContents,
                                                               getModTime)
import           Development.IDE.Core.IdeConfiguration
import           Development.IDE.Core.OfInterest hiding (LogShake, Log)
import           Development.IDE.Core.PositionMapping
import           Development.IDE.Core.RuleTypes
import           Development.IDE.Core.Service hiding (LogShake, Log)
import           Development.IDE.Core.Shake hiding (Log)
import           Development.IDE.GHC.Compat.Env
import           Development.IDE.GHC.Compat                   hiding
                                                              (vcat, nest, parseModule,
                                                               TargetId(..),
                                                               loadInterface,
                                                               Var,
                                                               (<+>), settings)
import qualified Development.IDE.GHC.Compat                   as Compat hiding (vcat, nest)
import qualified Development.IDE.GHC.Compat.Util              as Util
import           Development.IDE.GHC.Error
import           Development.IDE.GHC.Util                     hiding
                                                              (modifyDynFlags)
import           Development.IDE.Graph
import           Development.IDE.Import.DependencyInformation
import           Development.IDE.Import.FindImports
import qualified Development.IDE.Spans.AtPoint                as AtPoint
import           Development.IDE.Spans.Documentation
import           Development.IDE.Spans.LocalBindings
import           Development.IDE.Types.Diagnostics            as Diag
import           Development.IDE.Types.HscEnvEq
import           Development.IDE.Types.Location
import           Development.IDE.Types.Options
import qualified GHC.LanguageExtensions                       as LangExt
import qualified HieDb
import           Ide.Plugin.Config
import qualified Language.LSP.Server                          as LSP
import           Language.LSP.Protocol.Types                  (ShowMessageParams (ShowMessageParams), MessageType (MessageType_Info))
import           Language.LSP.Protocol.Message                (SMethod (SMethod_CustomMethod, SMethod_WindowShowMessage))
import           Language.LSP.VFS
import           System.Directory                             (makeAbsolute, doesFileExist)
import           Data.Default                                 (def, Default)
import           Ide.Plugin.Properties                        (HasProperty,
                                                               KeyNameProxy,
                                                               Properties,
                                                               ToHsType,
                                                               useProperty)
import           Ide.Types                                    (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser),
                                                               PluginId)
import Control.Concurrent.STM.Stats (atomically)
import Language.LSP.Server (LspT)
import System.Info.Extra (isWindows)
import HIE.Bios.Ghc.Gap (hostIsDynamic)
import Ide.Logger (Recorder, logWith, cmapWithPrio, WithPriority, Pretty (pretty), (<+>), nest, vcat)
import qualified Development.IDE.Core.Shake as Shake
import qualified Ide.Logger as Logger
import qualified Development.IDE.Types.Shake as Shake
import           Data.Time.Clock.POSIX             (posixSecondsToUTCTime)
import Control.Monad.IO.Unlift


import GHC.Fingerprint

-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]

#if !MIN_VERSION_ghc(9,3,0)
import GHC (mgModSummaries)
#endif

#if MIN_VERSION_ghc(9,3,0)
import qualified Data.IntMap as IM
#endif



data Log
  = LogShake Shake.Log
  | LogReindexingHieFile !NormalizedFilePath
  | LogLoadingHieFile !NormalizedFilePath
  | LogLoadingHieFileFail !FilePath !SomeException
  | LogLoadingHieFileSuccess !FilePath
  | LogTypecheckedFOI !NormalizedFilePath
  deriving Int -> Log -> ShowS
[Log] -> ShowS
Log -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Log] -> ShowS
$cshowList :: [Log] -> ShowS
show :: Log -> [Char]
$cshow :: Log -> [Char]
showsPrec :: Int -> Log -> ShowS
$cshowsPrec :: Int -> Log -> ShowS
Show

instance Pretty Log where
  pretty :: forall ann. Log -> Doc ann
pretty = \case
    LogShake Log
msg -> forall a ann. Pretty a => a -> Doc ann
pretty Log
msg
    LogReindexingHieFile NormalizedFilePath
path ->
      Doc ann
"Re-indexing hie file for" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
path)
    LogLoadingHieFile NormalizedFilePath
path ->
      Doc ann
"LOADING HIE FILE FOR" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
path)
    LogLoadingHieFileFail [Char]
path SomeException
e ->
      forall ann. Int -> Doc ann -> Doc ann
nest Int
2 forall a b. (a -> b) -> a -> b
$
        forall ann. [Doc ann] -> Doc ann
vcat
          [ Doc ann
"FAILED LOADING HIE FILE FOR" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty [Char]
path
          , forall a ann. Pretty a => a -> Doc ann
pretty (forall e. Exception e => e -> [Char]
displayException SomeException
e) ]
    LogLoadingHieFileSuccess [Char]
path ->
      Doc ann
"SUCCEEDED LOADING HIE FILE FOR" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty [Char]
path
    LogTypecheckedFOI NormalizedFilePath
path -> forall ann. [Doc ann] -> Doc ann
vcat
      [ Doc ann
"Typechecked a file which is not currently open in the editor:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
path)
      , Doc ann
"This can indicate a bug which results in excessive memory usage."
      , Doc ann
"This may be a spurious warning if you have recently closed the file."
      , Doc ann
"If you haven't opened this file recently, please file a report on the issue tracker mentioning"
        forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"the HLS version being used, the plugins enabled, and if possible the codebase and file which"
        forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"triggered this warning."
      ]

templateHaskellInstructions :: T.Text
templateHaskellInstructions :: Text
templateHaskellInstructions = Text
"https://haskell-language-server.readthedocs.io/en/latest/troubleshooting.html#static-binaries"

-- | 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
-- warnings while also producing a result.
toIdeResult :: Either [FileDiagnostic] v -> IdeResult v
toIdeResult :: forall v. Either [FileDiagnostic] v -> IdeResult v
toIdeResult = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (, forall a. Maybe a
Nothing) (([],) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just)

------------------------------------------------------------
-- Exposed API
------------------------------------------------------------
getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString
getSourceFileSource :: NormalizedFilePath -> Action ByteString
getSourceFileSource NormalizedFilePath
nfp = do
    (UTCTime
_, Maybe Text
msource) <- NormalizedFilePath -> Action (UTCTime, Maybe Text)
getFileContents NormalizedFilePath
nfp
    case Maybe Text
msource of
        Maybe Text
Nothing     -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
BS.readFile (NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
nfp)
        Just Text
source -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 Text
source

-- | Parse the contents of a haskell file.
getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)
getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)
getParsedModule = forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetParsedModule
GetParsedModule

-- | Parse the contents of a haskell file,
-- ensuring comments are preserved in annotations
getParsedModuleWithComments :: NormalizedFilePath -> Action (Maybe ParsedModule)
getParsedModuleWithComments :: NormalizedFilePath -> Action (Maybe ParsedModule)
getParsedModuleWithComments = forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetParsedModuleWithComments
GetParsedModuleWithComments

------------------------------------------------------------
-- Rules
-- These typically go from key to value and are oracles.

priorityTypeCheck :: Priority
priorityTypeCheck :: Priority
priorityTypeCheck = Double -> Priority
Priority Double
0

priorityGenerateCore :: Priority
priorityGenerateCore :: Priority
priorityGenerateCore = Double -> Priority
Priority (-Double
1)

priorityFilesOfInterest :: Priority
priorityFilesOfInterest :: Priority
priorityFilesOfInterest = Double -> Priority
Priority (-Double
2)

-- | WARNING:
-- We currently parse the module both with and without Opt_Haddock, and
-- return the one with Haddocks if it -- succeeds. However, this may not work
-- for hlint or any client code that might need the parsed source with all
-- annotations, including comments.
-- For that use case you might want to use `getParsedModuleWithCommentsRule`
-- See https://github.com/haskell/ghcide/pull/350#discussion_r370878197
-- and https://github.com/mpickering/ghcide/pull/22#issuecomment-625070490
-- GHC wiki about: https://gitlab.haskell.org/ghc/ghc/-/wikis/api-annotations
getParsedModuleRule :: Recorder (WithPriority Log) -> Rules ()
getParsedModuleRule :: Recorder (WithPriority Log) -> Rules ()
getParsedModuleRule Recorder (WithPriority Log)
recorder =
  -- this rule does not have early cutoff since all its dependencies already have it
  forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \GetParsedModule
GetParsedModule NormalizedFilePath
file -> do
    ModSummaryResult{msrModSummary :: ModSummaryResult -> ModSummary
msrModSummary = ModSummary
ms', msrHscEnv :: ModSummaryResult -> HscEnv
msrHscEnv = HscEnv
hsc} <- forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModSummary
GetModSummary NormalizedFilePath
file
    IdeOptions
opt <- Action IdeOptions
getIdeOptions
    DynFlags -> DynFlags
modify_dflags <- forall a. (DynFlagsModifications -> a) -> Action a
getModifyDynFlags DynFlagsModifications -> DynFlags -> DynFlags
dynFlagsModifyParser
    let ms :: ModSummary
ms = ModSummary
ms' { ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags -> DynFlags
modify_dflags forall a b. (a -> b) -> a -> b
$ ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms' }
        reset_ms :: ParsedModule -> ParsedModule
reset_ms ParsedModule
pm = ParsedModule
pm { pm_mod_summary :: ModSummary
pm_mod_summary = ModSummary
ms' }

    -- We still parse with Haddocks whether Opt_Haddock is True or False to collect information
    -- but we no longer need to parse with and without Haddocks separately for above GHC90.
    res :: ([FileDiagnostic], Maybe ParsedModule)
res@([FileDiagnostic]
_,Maybe ParsedModule
pmod) <- if GhcVersion
Compat.ghcVersion forall a. Ord a => a -> a -> Bool
>= GhcVersion
Compat.GHC90 then
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) ParsedModule -> ParsedModule
reset_ms forall a b. (a -> b) -> a -> b
$ HscEnv
-> IdeOptions
-> NormalizedFilePath
-> ModSummary
-> IO ([FileDiagnostic], Maybe ParsedModule)
getParsedModuleDefinition HscEnv
hsc IdeOptions
opt NormalizedFilePath
file (ModSummary -> ModSummary
withOptHaddock ModSummary
ms)
    else do
        let dflags :: DynFlags
dflags    = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms
            mainParse :: IO ([FileDiagnostic], Maybe ParsedModule)
mainParse = HscEnv
-> IdeOptions
-> NormalizedFilePath
-> ModSummary
-> IO ([FileDiagnostic], Maybe ParsedModule)
getParsedModuleDefinition HscEnv
hsc IdeOptions
opt NormalizedFilePath
file ModSummary
ms

        -- Parse again (if necessary) to capture Haddock parse errors
        if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Haddock DynFlags
dflags
            then
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) ParsedModule -> ParsedModule
reset_ms IO ([FileDiagnostic], Maybe ParsedModule)
mainParse
            else do
                let haddockParse :: IO ([FileDiagnostic], Maybe ParsedModule)
haddockParse = HscEnv
-> IdeOptions
-> NormalizedFilePath
-> ModSummary
-> IO ([FileDiagnostic], Maybe ParsedModule)
getParsedModuleDefinition HscEnv
hsc IdeOptions
opt NormalizedFilePath
file (ModSummary -> ModSummary
withOptHaddock ModSummary
ms)

                -- parse twice, with and without Haddocks, concurrently
                -- we cannot ignore Haddock parse errors because files of
                -- non-interest are always parsed with Haddocks
                -- If we can parse Haddocks, might as well use them
                (([FileDiagnostic]
diags,Maybe ParsedModule
res),([FileDiagnostic]
diagsh,Maybe ParsedModule
resh)) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) ParsedModule -> ParsedModule
reset_ms forall a b. (a -> b) -> a -> b
$ forall a b. IO a -> IO b -> IO (a, b)
concurrently IO ([FileDiagnostic], Maybe ParsedModule)
mainParse IO ([FileDiagnostic], Maybe ParsedModule)
haddockParse

                -- Merge haddock and regular diagnostics so we can always report haddock
                -- parse errors
                let diagsM :: [FileDiagnostic]
diagsM = [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic]
mergeParseErrorsHaddock [FileDiagnostic]
diags [FileDiagnostic]
diagsh
                case Maybe ParsedModule
resh of
                  Just ParsedModule
_
                    | OptHaddockParse
HaddockParse <- IdeOptions -> OptHaddockParse
optHaddockParse IdeOptions
opt
                    -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FileDiagnostic]
diagsM, Maybe ParsedModule
resh)
                  -- If we fail to parse haddocks, report the haddock diagnostics as well and
                  -- return the non-haddock parse.
                  -- This seems to be the correct behaviour because the Haddock flag is added
                  -- by us and not the user, so our IDE shouldn't stop working because of it.
                  Maybe ParsedModule
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FileDiagnostic]
diagsM, Maybe ParsedModule
res)
    -- Add dependencies on included files
    [Maybe FileVersion]
_ <- forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses GetModificationTime
GetModificationTime forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map [Char] -> NormalizedFilePath
toNormalizedFilePath' (forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ParsedModule -> [[Char]]
pm_extra_src_files Maybe ParsedModule
pmod)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FileDiagnostic], Maybe ParsedModule)
res

withOptHaddock :: ModSummary -> ModSummary
withOptHaddock :: ModSummary -> ModSummary
withOptHaddock = GeneralFlag -> ModSummary -> ModSummary
withOption GeneralFlag
Opt_Haddock

withOption :: GeneralFlag -> ModSummary -> ModSummary
withOption :: GeneralFlag -> ModSummary -> ModSummary
withOption GeneralFlag
opt ModSummary
ms = ModSummary
ms{ms_hspp_opts :: DynFlags
ms_hspp_opts= DynFlags -> GeneralFlag -> DynFlags
gopt_set (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) GeneralFlag
opt}

withoutOption :: GeneralFlag -> ModSummary -> ModSummary
withoutOption :: GeneralFlag -> ModSummary -> ModSummary
withoutOption GeneralFlag
opt ModSummary
ms = ModSummary
ms{ms_hspp_opts :: DynFlags
ms_hspp_opts= DynFlags -> GeneralFlag -> DynFlags
gopt_unset (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) GeneralFlag
opt}

-- | Given some normal parse errors (first) and some from Haddock (second), merge them.
--   Ignore Haddock errors that are in both. Demote Haddock-only errors to warnings.
mergeParseErrorsHaddock :: [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic]
mergeParseErrorsHaddock :: [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic]
mergeParseErrorsHaddock [FileDiagnostic]
normal [FileDiagnostic]
haddock = [FileDiagnostic]
normal forall a. [a] -> [a] -> [a]
++
    [ (NormalizedFilePath
a,ShowDiagnostic
b,Diagnostic
c{$sel:_severity:Diagnostic :: Maybe DiagnosticSeverity
_severity = forall a. a -> Maybe a
Just DiagnosticSeverity
DiagnosticSeverity_Warning, $sel:_message:Diagnostic :: Text
_message = Text -> Text
fixMessage forall a b. (a -> b) -> a -> b
$ Diagnostic -> Text
_message Diagnostic
c})
    | (NormalizedFilePath
a,ShowDiagnostic
b,Diagnostic
c) <- [FileDiagnostic]
haddock, Diagnostic -> Range
Diag._range Diagnostic
c forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Range
locations]
  where
    locations :: Set Range
locations = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Diagnostic -> Range
Diag._range forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a, b, c) -> c
thd3) [FileDiagnostic]
normal

    fixMessage :: Text -> Text
fixMessage Text
x | Text
"parse error " Text -> Text -> Bool
`T.isPrefixOf` Text
x = Text
"Haddock " forall a. Semigroup a => a -> a -> a
<> Text
x
                 | Bool
otherwise = Text
"Haddock: " forall a. Semigroup a => a -> a -> a
<> Text
x

-- | This rule provides a ParsedModule preserving all annotations,
-- including keywords, punctuation and comments.
-- So it is suitable for use cases where you need a perfect edit.
getParsedModuleWithCommentsRule :: Recorder (WithPriority Log) -> Rules ()
getParsedModuleWithCommentsRule :: Recorder (WithPriority Log) -> Rules ()
getParsedModuleWithCommentsRule Recorder (WithPriority Log)
recorder =
  -- The parse diagnostics are owned by the GetParsedModule rule
  -- For this reason, this rule does not produce any diagnostics
  forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ()
defineNoDiagnostics (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \GetParsedModuleWithComments
GetParsedModuleWithComments NormalizedFilePath
file -> do
    ModSummaryResult{msrModSummary :: ModSummaryResult -> ModSummary
msrModSummary = ModSummary
ms, msrHscEnv :: ModSummaryResult -> HscEnv
msrHscEnv = HscEnv
hsc} <- forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModSummary
GetModSummary NormalizedFilePath
file
    IdeOptions
opt <- Action IdeOptions
getIdeOptions

    let ms' :: ModSummary
ms' = GeneralFlag -> ModSummary -> ModSummary
withoutOption GeneralFlag
Opt_Haddock forall a b. (a -> b) -> a -> b
$ GeneralFlag -> ModSummary -> ModSummary
withOption GeneralFlag
Opt_KeepRawTokenStream ModSummary
ms
    DynFlags -> DynFlags
modify_dflags <- forall a. (DynFlagsModifications -> a) -> Action a
getModifyDynFlags DynFlagsModifications -> DynFlags -> DynFlags
dynFlagsModifyParser
    let ms'' :: ModSummary
ms'' = ModSummary
ms' { ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags -> DynFlags
modify_dflags forall a b. (a -> b) -> a -> b
$ ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms' }
        reset_ms :: ParsedModule -> ParsedModule
reset_ms ParsedModule
pm = ParsedModule
pm { pm_mod_summary :: ModSummary
pm_mod_summary = ModSummary
ms' }

    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParsedModule -> ParsedModule
reset_ms) forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv
-> IdeOptions
-> NormalizedFilePath
-> ModSummary
-> IO ([FileDiagnostic], Maybe ParsedModule)
getParsedModuleDefinition HscEnv
hsc IdeOptions
opt NormalizedFilePath
file ModSummary
ms''

getModifyDynFlags :: (DynFlagsModifications -> a) -> Action a
getModifyDynFlags :: forall a. (DynFlagsModifications -> a) -> Action a
getModifyDynFlags DynFlagsModifications -> a
f = do
  IdeOptions
opts <- Action IdeOptions
getIdeOptions
  Config
cfg <- Action Config
getClientConfigAction
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ DynFlagsModifications -> a
f forall a b. (a -> b) -> a -> b
$ IdeOptions -> Config -> DynFlagsModifications
optModifyDynFlags IdeOptions
opts Config
cfg


getParsedModuleDefinition
    :: HscEnv
    -> IdeOptions
    -> NormalizedFilePath
    -> ModSummary -> IO ([FileDiagnostic], Maybe ParsedModule)
getParsedModuleDefinition :: HscEnv
-> IdeOptions
-> NormalizedFilePath
-> ModSummary
-> IO ([FileDiagnostic], Maybe ParsedModule)
getParsedModuleDefinition HscEnv
packageState IdeOptions
opt NormalizedFilePath
file ModSummary
ms = do
    let fp :: [Char]
fp = NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
file
    ([FileDiagnostic]
diag, Maybe ParsedModule
res) <- IdeOptions
-> HscEnv
-> [Char]
-> ModSummary
-> IO ([FileDiagnostic], Maybe ParsedModule)
parseModule IdeOptions
opt HscEnv
packageState [Char]
fp ModSummary
ms
    case Maybe ParsedModule
res of
        Maybe ParsedModule
Nothing   -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FileDiagnostic]
diag, forall a. Maybe a
Nothing)
        Just ParsedModule
modu -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FileDiagnostic]
diag, forall a. a -> Maybe a
Just ParsedModule
modu)

getLocatedImportsRule :: Recorder (WithPriority Log) -> Rules ()
getLocatedImportsRule :: Recorder (WithPriority Log) -> Rules ()
getLocatedImportsRule Recorder (WithPriority Log)
recorder =
    forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \GetLocatedImports
GetLocatedImports NormalizedFilePath
file -> do
        ModSummaryResult{msrModSummary :: ModSummaryResult -> ModSummary
msrModSummary = ModSummary
ms} <- forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModSummaryWithoutTimestamps
GetModSummaryWithoutTimestamps NormalizedFilePath
file
        KnownTargets
targets <- forall k v. IdeRule k v => k -> Action v
useNoFile_ GetKnownTargets
GetKnownTargets
        let targetsMap :: HashMap Target Target
targetsMap = forall k v1 v2. (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2
HM.mapWithKey forall a b. a -> b -> a
const KnownTargets
targets
        let imports :: [(Bool, (Maybe FastString, Located ModuleName))]
imports = [(Bool
False, (Maybe FastString, Located ModuleName)
imp) | (Maybe FastString, Located ModuleName)
imp <- ModSummary -> [(Maybe FastString, Located ModuleName)]
ms_textual_imps ModSummary
ms] forall a. [a] -> [a] -> [a]
++ [(Bool
True, (Maybe FastString, Located ModuleName)
imp) | (Maybe FastString, Located ModuleName)
imp <- ModSummary -> [(Maybe FastString, Located ModuleName)]
ms_srcimps ModSummary
ms]
        HscEnvEq
env_eq <- forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GhcSession
GhcSession NormalizedFilePath
file
        let env :: HscEnv
env = HscEnvEq -> HscEnv
hscEnvWithImportPaths HscEnvEq
env_eq
        let import_dirs :: [(UnitId, DynFlags)]
import_dirs = HscEnvEq -> [(UnitId, DynFlags)]
deps HscEnvEq
env_eq
        let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
env
            isImplicitCradle :: Bool
isImplicitCradle = forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ HscEnvEq -> Maybe (Set [Char])
envImportPaths HscEnvEq
env_eq
        DynFlags
dflags' <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
isImplicitCradle
                    then NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags
addRelativeImport NormalizedFilePath
file (forall unit. GenModule unit -> ModuleName
moduleName forall a b. (a -> b) -> a -> b
$ ModSummary -> Module
ms_mod ModSummary
ms) DynFlags
dflags
                    else DynFlags
dflags
        IdeOptions
opt <- Action IdeOptions
getIdeOptions
        let getTargetFor :: ModuleName
-> NormalizedFilePath -> Action (Maybe NormalizedFilePath)
getTargetFor ModuleName
modName NormalizedFilePath
nfp
                | Bool
isImplicitCradle = do
                    Bool
itExists <- NormalizedFilePath -> Action Bool
getFileExists NormalizedFilePath
nfp
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
itExists then forall a. a -> Maybe a
Just NormalizedFilePath
nfp else forall a. Maybe a
Nothing
                | Just (TargetFile NormalizedFilePath
nfp') <- forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (NormalizedFilePath -> Target
TargetFile NormalizedFilePath
nfp) HashMap Target Target
targetsMap = do
                    -- reuse the existing NormalizedFilePath in order to maximize sharing
                    Bool
itExists <- NormalizedFilePath -> Action Bool
getFileExists NormalizedFilePath
nfp'
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
itExists then forall a. a -> Maybe a
Just NormalizedFilePath
nfp' else forall a. Maybe a
Nothing
                | Just HashSet NormalizedFilePath
tt <- forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (ModuleName -> Target
TargetModule ModuleName
modName) KnownTargets
targets = do
                    -- reuse the existing NormalizedFilePath in order to maximize sharing
                    let ttmap :: HashMap NormalizedFilePath NormalizedFilePath
ttmap = forall k v1 v2. (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2
HM.mapWithKey forall a b. a -> b -> a
const (forall a. HashSet a -> HashMap a ()
HashSet.toMap HashSet NormalizedFilePath
tt)
                        nfp' :: NormalizedFilePath
nfp' = forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
HM.lookupDefault NormalizedFilePath
nfp NormalizedFilePath
nfp HashMap NormalizedFilePath NormalizedFilePath
ttmap
                    Bool
itExists <- NormalizedFilePath -> Action Bool
getFileExists NormalizedFilePath
nfp'
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
itExists then forall a. a -> Maybe a
Just NormalizedFilePath
nfp' else forall a. Maybe a
Nothing
                | Bool
otherwise
                = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        ([[FileDiagnostic]]
diags, [Maybe (Located ModuleName, Maybe ArtifactsLocation)]
imports') <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Bool, (Maybe FastString, Located ModuleName))]
imports forall a b. (a -> b) -> a -> b
$ \(Bool
isSource, (Maybe FastString
mbPkgName, Located ModuleName
modName)) -> do
            Either [FileDiagnostic] Import
diagOrImp <- forall (m :: * -> *).
MonadIO m =>
HscEnv
-> [(UnitId, DynFlags)]
-> [[Char]]
-> (ModuleName
    -> NormalizedFilePath -> m (Maybe NormalizedFilePath))
-> Located ModuleName
-> Maybe FastString
-> Bool
-> m (Either [FileDiagnostic] Import)
locateModule (DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags' HscEnv
env) [(UnitId, DynFlags)]
import_dirs (IdeOptions -> [[Char]]
optExtensions IdeOptions
opt) ModuleName
-> NormalizedFilePath -> Action (Maybe NormalizedFilePath)
getTargetFor Located ModuleName
modName Maybe FastString
mbPkgName Bool
isSource
            case Either [FileDiagnostic] Import
diagOrImp of
                Left [FileDiagnostic]
diags              -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FileDiagnostic]
diags, forall a. a -> Maybe a
Just (Located ModuleName
modName, forall a. Maybe a
Nothing))
                Right (FileImport ArtifactsLocation
path) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], forall a. a -> Maybe a
Just (Located ModuleName
modName, forall a. a -> Maybe a
Just ArtifactsLocation
path))
                Right Import
PackageImport     -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], forall a. Maybe a
Nothing)

        {- IS THIS REALLY NEEDED? DOESNT SEEM SO

        -- does this module have an hs-boot file? If so add a direct dependency
        let bootPath = toNormalizedFilePath' $ fromNormalizedFilePath file <.> "hs-boot"
        boot <- use GetFileExists bootPath
        bootArtifact <- if boot == Just True
              then do
                let modName = ms_mod_name ms
                loc <- liftIO $ mkHomeModLocation dflags' modName (fromNormalizedFilePath bootPath)
                return $ Just (noLoc modName, Just (ArtifactsLocation bootPath (Just loc) True))
              else pure Nothing
        -}
        let bootArtifact :: Maybe a
bootArtifact = forall a. Maybe a
Nothing

        let moduleImports :: [(Located ModuleName, Maybe ArtifactsLocation)]
moduleImports = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a. Maybe a
bootArtifact forall a. a -> [a] -> [a]
: [Maybe (Located ModuleName, Maybe ArtifactsLocation)]
imports'
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FileDiagnostic]]
diags, forall a. a -> Maybe a
Just [(Located ModuleName, Maybe ArtifactsLocation)]
moduleImports)

type RawDepM a = StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action a

execRawDepM :: Monad m => StateT (RawDependencyInformation, IntMap a1) m a2 -> m (RawDependencyInformation, IntMap a1)
execRawDepM :: forall (m :: * -> *) a1 a2.
Monad m =>
StateT (RawDependencyInformation, IntMap a1) m a2
-> m (RawDependencyInformation, IntMap a1)
execRawDepM StateT (RawDependencyInformation, IntMap a1) m a2
act =
    forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT StateT (RawDependencyInformation, IntMap a1) m a2
act
        ( FilePathIdMap (Either ModuleParseError ModuleImports)
-> PathIdMap
-> FilePathIdMap ShowableModule
-> RawDependencyInformation
RawDependencyInformation forall a. IntMap a
IntMap.empty PathIdMap
emptyPathIdMap forall a. IntMap a
IntMap.empty
        , forall a. IntMap a
IntMap.empty
        )

-- | Given a target file path, construct the raw dependency results by following
-- imports recursively.
rawDependencyInformation :: [NormalizedFilePath] -> Action (RawDependencyInformation, BootIdMap)
rawDependencyInformation :: [NormalizedFilePath]
-> Action (RawDependencyInformation, BootIdMap)
rawDependencyInformation [NormalizedFilePath]
fs = do
    (RawDependencyInformation
rdi, IntMap ArtifactsLocation
ss) <- forall (m :: * -> *) a1 a2.
Monad m =>
StateT (RawDependencyInformation, IntMap a1) m a2
-> m (RawDependencyInformation, IntMap a1)
execRawDepM ([NormalizedFilePath]
-> StateT
     (RawDependencyInformation, IntMap ArtifactsLocation)
     Action
     [FilePathId]
goPlural [NormalizedFilePath]
fs)
    let bm :: BootIdMap
bm = forall a b. (Int -> a -> b -> b) -> b -> IntMap a -> b
IntMap.foldrWithKey (RawDependencyInformation
-> Int -> ArtifactsLocation -> BootIdMap -> BootIdMap
updateBootMap RawDependencyInformation
rdi) forall a. IntMap a
IntMap.empty IntMap ArtifactsLocation
ss
    forall (m :: * -> *) a. Monad m => a -> m a
return (RawDependencyInformation
rdi, BootIdMap
bm)
  where
    goPlural :: [NormalizedFilePath]
-> StateT
     (RawDependencyInformation, IntMap ArtifactsLocation)
     Action
     [FilePathId]
goPlural [NormalizedFilePath]
ff = do
        [Maybe ModSummary]
mss <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) ModSummaryResult -> ModSummary
msrModSummary forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses GetModSummaryWithoutTimestamps
GetModSummaryWithoutTimestamps [NormalizedFilePath]
ff
        forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM NormalizedFilePath -> Maybe ModSummary -> RawDepM FilePathId
go [NormalizedFilePath]
ff [Maybe ModSummary]
mss

    go :: NormalizedFilePath -- ^ Current module being processed
       -> Maybe ModSummary   -- ^ ModSummary of the module
       -> RawDepM FilePathId
    go :: NormalizedFilePath -> Maybe ModSummary -> RawDepM FilePathId
go NormalizedFilePath
f Maybe ModSummary
msum = do
      -- First check to see if we have already processed the FilePath
      -- If we have, just return its Id but don't update any of the state.
      -- Otherwise, we need to process its imports.
      NormalizedFilePath -> RawDepM FilePathId -> RawDepM FilePathId
checkAlreadyProcessed NormalizedFilePath
f forall a b. (a -> b) -> a -> b
$ do
          let al :: ArtifactsLocation
al = NormalizedFilePath -> Maybe ModSummary -> ArtifactsLocation
modSummaryToArtifactsLocation NormalizedFilePath
f Maybe ModSummary
msum
          -- Get a fresh FilePathId for the new file
          FilePathId
fId <- ArtifactsLocation -> RawDepM FilePathId
getFreshFid ArtifactsLocation
al
          -- Record this module and its location
          forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe ModSummary
msum forall a b. (a -> b) -> a -> b
$ \ModSummary
ms ->
            (RawDependencyInformation -> RawDependencyInformation)
-> StateT
     (RawDependencyInformation, IntMap ArtifactsLocation) Action ()
modifyRawDepInfo (\RawDependencyInformation
rd -> RawDependencyInformation
rd { rawModuleMap :: FilePathIdMap ShowableModule
rawModuleMap = forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert (FilePathId -> Int
getFilePathId FilePathId
fId)
                                                                           (Module -> ShowableModule
ShowableModule forall a b. (a -> b) -> a -> b
$ ModSummary -> Module
ms_mod ModSummary
ms)
                                                                           (RawDependencyInformation -> FilePathIdMap ShowableModule
rawModuleMap RawDependencyInformation
rd)})
          -- Adding an edge to the bootmap so we can make sure to
          -- insert boot nodes before the real files.
          ArtifactsLocation
-> FilePathId
-> StateT
     (RawDependencyInformation, IntMap ArtifactsLocation) Action ()
addBootMap ArtifactsLocation
al FilePathId
fId
          -- Try to parse the imports of the file
          Maybe [(Located ModuleName, Maybe ArtifactsLocation)]
importsOrErr <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetLocatedImports
GetLocatedImports NormalizedFilePath
f
          case Maybe [(Located ModuleName, Maybe ArtifactsLocation)]
importsOrErr of
            Maybe [(Located ModuleName, Maybe ArtifactsLocation)]
Nothing -> do
            -- File doesn't parse so add the module as a failure into the
            -- dependency information, continue processing the other
            -- elements in the queue
              (RawDependencyInformation -> RawDependencyInformation)
-> StateT
     (RawDependencyInformation, IntMap ArtifactsLocation) Action ()
modifyRawDepInfo (FilePathId
-> Either ModuleParseError ModuleImports
-> RawDependencyInformation
-> RawDependencyInformation
insertImport FilePathId
fId (forall a b. a -> Either a b
Left ModuleParseError
ModuleParseError))
              forall (m :: * -> *) a. Monad m => a -> m a
return FilePathId
fId
            Just [(Located ModuleName, Maybe ArtifactsLocation)]
modImports -> do
              -- Get NFPs of the imports which have corresponding files
              -- Imports either come locally from a file or from a package.
              let ([Located ModuleName]
no_file, [(Located ModuleName, ArtifactsLocation)]
with_file) = [(Located ModuleName, Maybe ArtifactsLocation)]
-> ([Located ModuleName],
    [(Located ModuleName, ArtifactsLocation)])
splitImports [(Located ModuleName, Maybe ArtifactsLocation)]
modImports
                  ([Located ModuleName]
mns, [ArtifactsLocation]
ls) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Located ModuleName, ArtifactsLocation)]
with_file
              -- Recursively process all the imports we just learnt about
              -- and get back a list of their FilePathIds
              [FilePathId]
fids <- [NormalizedFilePath]
-> StateT
     (RawDependencyInformation, IntMap ArtifactsLocation)
     Action
     [FilePathId]
goPlural forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ArtifactsLocation -> NormalizedFilePath
artifactFilePath [ArtifactsLocation]
ls
              -- Associate together the ModuleName with the FilePathId
              let moduleImports' :: [(Located ModuleName, Maybe FilePathId)]
moduleImports' = forall a b. (a -> b) -> [a] -> [b]
map (,forall a. Maybe a
Nothing) [Located ModuleName]
no_file forall a. [a] -> [a] -> [a]
++ forall a b. [a] -> [b] -> [(a, b)]
zip [Located ModuleName]
mns (forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just [FilePathId]
fids)
              -- Insert into the map the information about this modules
              -- imports.
              (RawDependencyInformation -> RawDependencyInformation)
-> StateT
     (RawDependencyInformation, IntMap ArtifactsLocation) Action ()
modifyRawDepInfo forall a b. (a -> b) -> a -> b
$ FilePathId
-> Either ModuleParseError ModuleImports
-> RawDependencyInformation
-> RawDependencyInformation
insertImport FilePathId
fId (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [(Located ModuleName, Maybe FilePathId)] -> ModuleImports
ModuleImports [(Located ModuleName, Maybe FilePathId)]
moduleImports')
              forall (m :: * -> *) a. Monad m => a -> m a
return FilePathId
fId


    checkAlreadyProcessed :: NormalizedFilePath -> RawDepM FilePathId -> RawDepM FilePathId
    checkAlreadyProcessed :: NormalizedFilePath -> RawDepM FilePathId -> RawDepM FilePathId
checkAlreadyProcessed NormalizedFilePath
nfp RawDepM FilePathId
k = do
      (RawDependencyInformation
rawDepInfo, IntMap ArtifactsLocation
_) <- forall s (m :: * -> *). MonadState s m => m s
get
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe RawDepM FilePathId
k forall (m :: * -> *) a. Monad m => a -> m a
return (PathIdMap -> NormalizedFilePath -> Maybe FilePathId
lookupPathToId (RawDependencyInformation -> PathIdMap
rawPathIdMap RawDependencyInformation
rawDepInfo) NormalizedFilePath
nfp)

    modifyRawDepInfo :: (RawDependencyInformation -> RawDependencyInformation) -> RawDepM ()
    modifyRawDepInfo :: (RawDependencyInformation -> RawDependencyInformation)
-> StateT
     (RawDependencyInformation, IntMap ArtifactsLocation) Action ()
modifyRawDepInfo RawDependencyInformation -> RawDependencyInformation
f = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall a a' b. (a -> a') -> (a, b) -> (a', b)
first RawDependencyInformation -> RawDependencyInformation
f)

    addBootMap ::  ArtifactsLocation -> FilePathId -> RawDepM ()
    addBootMap :: ArtifactsLocation
-> FilePathId
-> StateT
     (RawDependencyInformation, IntMap ArtifactsLocation) Action ()
addBootMap ArtifactsLocation
al FilePathId
fId =
      forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\(RawDependencyInformation
rd, IntMap ArtifactsLocation
ss) -> (RawDependencyInformation
rd, if ArtifactsLocation -> Bool
isBootLocation ArtifactsLocation
al
                                  then forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert (FilePathId -> Int
getFilePathId FilePathId
fId) ArtifactsLocation
al IntMap ArtifactsLocation
ss
                                  else IntMap ArtifactsLocation
ss))

    getFreshFid :: ArtifactsLocation -> RawDepM FilePathId
    getFreshFid :: ArtifactsLocation -> RawDepM FilePathId
getFreshFid ArtifactsLocation
al = do
      (RawDependencyInformation
rawDepInfo, IntMap ArtifactsLocation
ss) <- forall s (m :: * -> *). MonadState s m => m s
get
      let (FilePathId
fId, PathIdMap
path_map) = ArtifactsLocation -> PathIdMap -> (FilePathId, PathIdMap)
getPathId ArtifactsLocation
al (RawDependencyInformation -> PathIdMap
rawPathIdMap RawDependencyInformation
rawDepInfo)
      -- Insert the File into the bootmap if it's a boot module
      let rawDepInfo' :: RawDependencyInformation
rawDepInfo' = RawDependencyInformation
rawDepInfo { rawPathIdMap :: PathIdMap
rawPathIdMap = PathIdMap
path_map }
      forall s (m :: * -> *). MonadState s m => s -> m ()
put (RawDependencyInformation
rawDepInfo', IntMap ArtifactsLocation
ss)
      forall (m :: * -> *) a. Monad m => a -> m a
return FilePathId
fId

    -- Split in (package imports, local imports)
    splitImports :: [(Located ModuleName, Maybe ArtifactsLocation)]
                 -> ([Located ModuleName], [(Located ModuleName, ArtifactsLocation)])
    splitImports :: [(Located ModuleName, Maybe ArtifactsLocation)]
-> ([Located ModuleName],
    [(Located ModuleName, ArtifactsLocation)])
splitImports = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a} {b}. (a, Maybe b) -> ([a], [(a, b)]) -> ([a], [(a, b)])
splitImportsLoop ([],[])

    splitImportsLoop :: (a, Maybe b) -> ([a], [(a, b)]) -> ([a], [(a, b)])
splitImportsLoop (a
imp, Maybe b
Nothing) ([a]
ns, [(a, b)]
ls)       = (a
impforall a. a -> [a] -> [a]
:[a]
ns, [(a, b)]
ls)
    splitImportsLoop (a
imp, Just b
artifact) ([a]
ns, [(a, b)]
ls) = ([a]
ns, (a
imp,b
artifact) forall a. a -> [a] -> [a]
: [(a, b)]
ls)

    updateBootMap :: RawDependencyInformation
-> Int -> ArtifactsLocation -> BootIdMap -> BootIdMap
updateBootMap RawDependencyInformation
pm Int
boot_mod_id ArtifactsLocation{Bool
Maybe ModLocation
Maybe Module
NormalizedFilePath
artifactModule :: ArtifactsLocation -> Maybe Module
artifactIsSource :: ArtifactsLocation -> Bool
artifactModLocation :: ArtifactsLocation -> Maybe ModLocation
artifactModule :: Maybe Module
artifactIsSource :: Bool
artifactModLocation :: Maybe ModLocation
artifactFilePath :: NormalizedFilePath
artifactFilePath :: ArtifactsLocation -> NormalizedFilePath
..} BootIdMap
bm =
      if Bool -> Bool
not Bool
artifactIsSource
        then
          let msource_mod_id :: Maybe FilePathId
msource_mod_id = PathIdMap -> NormalizedFilePath -> Maybe FilePathId
lookupPathToId (RawDependencyInformation -> PathIdMap
rawPathIdMap RawDependencyInformation
pm) ([Char] -> NormalizedFilePath
toNormalizedFilePath' forall a b. (a -> b) -> a -> b
$ ShowS
dropBootSuffix forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
artifactFilePath)
          in case Maybe FilePathId
msource_mod_id of
               Just FilePathId
source_mod_id -> FilePathId -> FilePathId -> BootIdMap -> BootIdMap
insertBootId FilePathId
source_mod_id (Int -> FilePathId
FilePathId Int
boot_mod_id) BootIdMap
bm
               Maybe FilePathId
Nothing -> BootIdMap
bm
        else BootIdMap
bm

    dropBootSuffix :: FilePath -> FilePath
    dropBootSuffix :: ShowS
dropBootSuffix [Char]
hs_src = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length @[] [Char]
"-boot") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ [Char]
hs_src

reportImportCyclesRule :: Recorder (WithPriority Log) -> Rules ()
reportImportCyclesRule :: Recorder (WithPriority Log) -> Rules ()
reportImportCyclesRule Recorder (WithPriority Log)
recorder =
    forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
defineEarlyCutoff (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v))
-> RuleBody k v
Rule forall a b. (a -> b) -> a -> b
$ \ReportImportCycles
ReportImportCycles NormalizedFilePath
file -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[FileDiagnostic]
errs -> if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FileDiagnostic]
errs then (forall a. a -> Maybe a
Just ByteString
"1",([], forall a. a -> Maybe a
Just ())) else (forall a. Maybe a
Nothing, ([FileDiagnostic]
errs, forall a. Maybe a
Nothing))) forall a b. (a -> b) -> a -> b
$ do
        DependencyInformation{FilePathIdMap (NonEmpty NodeError)
IntMap IntSet
FilePathIdMap ShowableModule
BootIdMap
ModuleGraph
ShowableModuleEnv FilePathId
PathIdMap
depModuleGraph :: DependencyInformation -> ModuleGraph
depModuleFiles :: DependencyInformation -> ShowableModuleEnv FilePathId
depBootMap :: DependencyInformation -> BootIdMap
depPathIdMap :: DependencyInformation -> PathIdMap
depReverseModuleDeps :: DependencyInformation -> IntMap IntSet
depModuleDeps :: DependencyInformation -> IntMap IntSet
depModules :: DependencyInformation -> FilePathIdMap ShowableModule
depErrorNodes :: DependencyInformation -> FilePathIdMap (NonEmpty NodeError)
depModuleGraph :: ModuleGraph
depModuleFiles :: ShowableModuleEnv FilePathId
depBootMap :: BootIdMap
depPathIdMap :: PathIdMap
depReverseModuleDeps :: IntMap IntSet
depModuleDeps :: IntMap IntSet
depModules :: FilePathIdMap ShowableModule
depErrorNodes :: FilePathIdMap (NonEmpty NodeError)
..} <- forall k v. IdeRule k v => k -> Action v
useNoFile_ GetModuleGraph
GetModuleGraph
        case PathIdMap -> NormalizedFilePath -> Maybe FilePathId
pathToId PathIdMap
depPathIdMap NormalizedFilePath
file of
          -- The header of the file does not parse, so it can't be part of any import cycles.
          Maybe FilePathId
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
          Just FilePathId
fileId ->
            case forall a. Int -> IntMap a -> Maybe a
IntMap.lookup (FilePathId -> Int
getFilePathId FilePathId
fileId) FilePathIdMap (NonEmpty NodeError)
depErrorNodes of
              Maybe (NonEmpty NodeError)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
              Just NonEmpty NodeError
errs -> do
                  let cycles :: [(Located ModuleName, [FilePathId])]
cycles = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (FilePathId -> NodeError -> Maybe (Located ModuleName, [FilePathId])
cycleErrorInFile FilePathId
fileId) (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty NodeError
errs)
                  -- Convert cycles of files into cycles of module names
                  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Located ModuleName, [FilePathId])]
cycles forall a b. (a -> b) -> a -> b
$ \(Located ModuleName
imp, [FilePathId]
files) -> do
                      [[Char]]
modNames <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePathId]
files forall a b. (a -> b) -> a -> b
$ 
                          NormalizedFilePath -> Action [Char]
getModuleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathIdMap -> FilePathId -> NormalizedFilePath
idToPath PathIdMap
depPathIdMap
                      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall {a}. HasSrcSpan a => a -> [[Char]] -> FileDiagnostic
toDiag Located ModuleName
imp forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
sort [[Char]]
modNames
    where cycleErrorInFile :: FilePathId -> NodeError -> Maybe (Located ModuleName, [FilePathId])
cycleErrorInFile FilePathId
f (PartOfCycle Located ModuleName
imp [FilePathId]
fs)
            | FilePathId
f forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePathId]
fs = forall a. a -> Maybe a
Just (Located ModuleName
imp, [FilePathId]
fs)
          cycleErrorInFile FilePathId
_ NodeError
_ = forall a. Maybe a
Nothing
          toDiag :: a -> [[Char]] -> FileDiagnostic
toDiag a
imp [[Char]]
mods = (NormalizedFilePath
fp , ShowDiagnostic
ShowDiag , ) forall a b. (a -> b) -> a -> b
$ Diagnostic
            { $sel:_range:Diagnostic :: Range
_range = Range
rng
            , $sel:_severity:Diagnostic :: Maybe DiagnosticSeverity
_severity = forall a. a -> Maybe a
Just DiagnosticSeverity
DiagnosticSeverity_Error
            , $sel:_source:Diagnostic :: Maybe Text
_source = forall a. a -> Maybe a
Just Text
"Import cycle detection"
            , $sel:_message:Diagnostic :: Text
_message = Text
"Cyclic module dependency between " forall a. Semigroup a => a -> a -> a
<> [[Char]] -> Text
showCycle [[Char]]
mods
            , $sel:_code:Diagnostic :: Maybe (Int32 |? Text)
_code = forall a. Maybe a
Nothing
            , $sel:_relatedInformation:Diagnostic :: Maybe [DiagnosticRelatedInformation]
_relatedInformation = forall a. Maybe a
Nothing
            , $sel:_tags:Diagnostic :: Maybe [DiagnosticTag]
_tags = forall a. Maybe a
Nothing
            , $sel:_codeDescription:Diagnostic :: Maybe CodeDescription
_codeDescription = forall a. Maybe a
Nothing
            , $sel:_data_:Diagnostic :: Maybe Value
_data_ = forall a. Maybe a
Nothing
            }
            where rng :: Range
rng = forall a. a -> Maybe a -> a
fromMaybe Range
noRange forall a b. (a -> b) -> a -> b
$ SrcSpan -> Maybe Range
srcSpanToRange (forall a. HasSrcSpan a => a -> SrcSpan
getLoc a
imp)
                  fp :: NormalizedFilePath
fp = [Char] -> NormalizedFilePath
toNormalizedFilePath' forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe [Char]
noFilePath forall a b. (a -> b) -> a -> b
$ SrcSpan -> Maybe [Char]
srcSpanToFilename (forall a. HasSrcSpan a => a -> SrcSpan
getLoc a
imp)
          getModuleName :: NormalizedFilePath -> Action [Char]
getModuleName NormalizedFilePath
file = do
           ModSummary
ms <- ModSummaryResult -> ModSummary
msrModSummary forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModSummaryWithoutTimestamps
GetModSummaryWithoutTimestamps NormalizedFilePath
file
           forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModuleName -> [Char]
moduleNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall unit. GenModule unit -> ModuleName
moduleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Module
ms_mod forall a b. (a -> b) -> a -> b
$ ModSummary
ms)
          showCycle :: [[Char]] -> Text
showCycle [[Char]]
mods  = Text -> [Text] -> Text
T.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
T.pack [[Char]]
mods)

getHieAstsRule :: Recorder (WithPriority Log) -> Rules ()
getHieAstsRule :: Recorder (WithPriority Log) -> Rules ()
getHieAstsRule Recorder (WithPriority Log)
recorder =
    forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \GetHieAst
GetHieAst NormalizedFilePath
f -> do
      TcModuleResult
tmr <- forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ TypeCheck
TypeCheck NormalizedFilePath
f
      HscEnv
hsc <- HscEnvEq -> HscEnv
hscEnv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GhcSessionDeps
GhcSessionDeps NormalizedFilePath
f
      NormalizedFilePath
-> HscEnv -> TcModuleResult -> Action (IdeResult HieAstResult)
getHieAstRuleDefinition NormalizedFilePath
f HscEnv
hsc TcModuleResult
tmr

persistentHieFileRule :: Recorder (WithPriority Log) -> Rules ()
persistentHieFileRule :: Recorder (WithPriority Log) -> Rules ()
persistentHieFileRule Recorder (WithPriority Log)
recorder = forall k v.
IdeRule k v =>
k
-> (NormalizedFilePath
    -> IdeAction (Maybe (v, PositionDelta, Maybe Int32)))
-> Rules ()
addPersistentRule GetHieAst
GetHieAst forall a b. (a -> b) -> a -> b
$ \NormalizedFilePath
file -> forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
  HieFile
res <- Recorder (WithPriority Log)
-> NormalizedFilePath -> MaybeT IdeAction HieFile
readHieFileForSrcFromDisk Recorder (WithPriority Log)
recorder NormalizedFilePath
file
  TVar VFS
vfsRef <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ShakeExtras -> TVar VFS
vfsVar
  Map NormalizedUri VirtualFile
vfsData <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ VFS -> Map NormalizedUri VirtualFile
_vfsMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> IO a
readTVarIO TVar VFS
vfsRef
  (Text
currentSource, Maybe Int32
ver) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (NormalizedFilePath -> NormalizedUri
filePathToUri' NormalizedFilePath
file) Map NormalizedUri VirtualFile
vfsData of
    Maybe VirtualFile
Nothing -> (,forall a. Maybe a
Nothing) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO ByteString
BS.readFile (NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
file)
    Just VirtualFile
vf -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rope -> Text
Rope.toText forall a b. (a -> b) -> a -> b
$ VirtualFile -> Rope
_file_text VirtualFile
vf, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ VirtualFile -> Int32
_lsp_version VirtualFile
vf)
  let refmap :: RefMap Int
refmap = forall (f :: * -> *) a. Foldable f => f (HieAST a) -> RefMap a
Compat.generateReferencesMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HieASTs a -> Map HiePath (HieAST a)
Compat.getAsts forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieFile -> HieASTs Int
Compat.hie_asts forall a b. (a -> b) -> a -> b
$ HieFile
res
      del :: PositionDelta
del = Text -> Text -> PositionDelta
deltaFromDiff (ByteString -> Text
T.decodeUtf8 forall a b. (a -> b) -> a -> b
$ HieFile -> ByteString
Compat.hie_hs_src HieFile
res) Text
currentSource
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a.
Typeable a =>
Module
-> HieASTs a
-> RefMap a
-> Map Name [RealSrcSpan]
-> HieKind a
-> HieAstResult
HAR (HieFile -> Module
Compat.hie_module HieFile
res) (HieFile -> HieASTs Int
Compat.hie_asts HieFile
res) RefMap Int
refmap forall a. Monoid a => a
mempty (HieFile -> HieKind Int
HieFromDisk HieFile
res),PositionDelta
del,Maybe Int32
ver)

getHieAstRuleDefinition :: NormalizedFilePath -> HscEnv -> TcModuleResult -> Action (IdeResult HieAstResult)
getHieAstRuleDefinition :: NormalizedFilePath
-> HscEnv -> TcModuleResult -> Action (IdeResult HieAstResult)
getHieAstRuleDefinition NormalizedFilePath
f HscEnv
hsc TcModuleResult
tmr = do
  ([FileDiagnostic]
diags, Maybe (HieASTs Type)
masts) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> TcModuleResult -> IO ([FileDiagnostic], Maybe (HieASTs Type))
generateHieAsts HscEnv
hsc TcModuleResult
tmr
  ShakeExtras
se <- Action ShakeExtras
getShakeExtras

  IsFileOfInterestResult
isFoi <- forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ IsFileOfInterest
IsFileOfInterest NormalizedFilePath
f
  [FileDiagnostic]
diagsWrite <- case IsFileOfInterestResult
isFoi of
    IsFOI Modified{firstOpen :: FileOfInterestStatus -> Bool
firstOpen = Bool
False} -> do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ ShakeExtras -> IdeTesting
ideTesting ShakeExtras
se) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) c.
Applicative m =>
Maybe (LanguageContextEnv c) -> LspT c m () -> m ()
mRunLspT (ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv ShakeExtras
se) forall a b. (a -> b) -> a -> b
$
        forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification (forall {f :: MessageDirection} {t :: MessageKind} (s :: Symbol).
KnownSymbol s =>
Proxy s -> SMethod ('Method_CustomMethod s)
SMethod_CustomMethod (forall {k} (t :: k). Proxy t
Proxy @"ghcide/reference/ready")) forall a b. (a -> b) -> a -> b
$
          forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
f
      forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    IsFileOfInterestResult
_ | Just HieASTs Type
asts <- Maybe (HieASTs Type)
masts -> do
          ByteString
source <- NormalizedFilePath -> Action ByteString
getSourceFileSource NormalizedFilePath
f
          let exports :: [AvailInfo]
exports = TcGblEnv -> [AvailInfo]
tcg_exports forall a b. (a -> b) -> a -> b
$ TcModuleResult -> TcGblEnv
tmrTypechecked TcModuleResult
tmr
              msum :: ModSummary
msum = TcModuleResult -> ModSummary
tmrModSummary TcModuleResult
tmr
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> ShakeExtras
-> ModSummary
-> NormalizedFilePath
-> [AvailInfo]
-> HieASTs Type
-> ByteString
-> IO [FileDiagnostic]
writeAndIndexHieFile HscEnv
hsc ShakeExtras
se ModSummary
msum NormalizedFilePath
f [AvailInfo]
exports HieASTs Type
asts ByteString
source
    IsFileOfInterestResult
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []

  let refmap :: Maybe (RefMap Type)
refmap = forall (f :: * -> *) a. Foldable f => f (HieAST a) -> RefMap a
Compat.generateReferencesMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HieASTs a -> Map HiePath (HieAST a)
Compat.getAsts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (HieASTs Type)
masts
      typemap :: Maybe (Map Name [RealSrcSpan])
typemap = forall (f :: * -> *).
Foldable f =>
f (HieAST Type) -> Map Name [RealSrcSpan]
AtPoint.computeTypeReferences forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HieASTs a -> Map HiePath (HieAST a)
Compat.getAsts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (HieASTs Type)
masts
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FileDiagnostic]
diags forall a. Semigroup a => a -> a -> a
<> [FileDiagnostic]
diagsWrite, forall a.
Typeable a =>
Module
-> HieASTs a
-> RefMap a
-> Map Name [RealSrcSpan]
-> HieKind a
-> HieAstResult
HAR (ModSummary -> Module
ms_mod forall a b. (a -> b) -> a -> b
$ TcModuleResult -> ModSummary
tmrModSummary TcModuleResult
tmr) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (HieASTs Type)
masts forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (RefMap Type)
refmap forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Map Name [RealSrcSpan])
typemap forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure HieKind Type
HieFresh)

getImportMapRule :: Recorder (WithPriority Log) -> Rules ()
getImportMapRule :: Recorder (WithPriority Log) -> Rules ()
getImportMapRule Recorder (WithPriority Log)
recorder = forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \GetImportMap
GetImportMap NormalizedFilePath
f -> do
  Maybe [(Located ModuleName, Maybe ArtifactsLocation)]
im <- forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetLocatedImports
GetLocatedImports NormalizedFilePath
f
  let mkImports :: [(GenLocated l k, Maybe ArtifactsLocation)]
-> Map k NormalizedFilePath
mkImports [(GenLocated l k, Maybe ArtifactsLocation)]
fileImports = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(GenLocated l k
m, Maybe ArtifactsLocation
mfp) -> (forall l e. GenLocated l e -> e
unLoc GenLocated l k
m,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArtifactsLocation -> NormalizedFilePath
artifactFilePath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ArtifactsLocation
mfp) [(GenLocated l k, Maybe ArtifactsLocation)]
fileImports
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Map ModuleName NormalizedFilePath -> ImportMap
ImportMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {l}.
Ord k =>
[(GenLocated l k, Maybe ArtifactsLocation)]
-> Map k NormalizedFilePath
mkImports forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [(Located ModuleName, Maybe ArtifactsLocation)]
im)

-- | Ensure that go to definition doesn't block on startup
persistentImportMapRule :: Rules ()
persistentImportMapRule :: Rules ()
persistentImportMapRule = forall k v.
IdeRule k v =>
k
-> (NormalizedFilePath
    -> IdeAction (Maybe (v, PositionDelta, Maybe Int32)))
-> Rules ()
addPersistentRule GetImportMap
GetImportMap forall a b. (a -> b) -> a -> b
$ \NormalizedFilePath
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Map ModuleName NormalizedFilePath -> ImportMap
ImportMap forall a. Monoid a => a
mempty, PositionDelta
idDelta, forall a. Maybe a
Nothing)

getBindingsRule :: Recorder (WithPriority Log) -> Rules ()
getBindingsRule :: Recorder (WithPriority Log) -> Rules ()
getBindingsRule Recorder (WithPriority Log)
recorder =
  forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \GetBindings
GetBindings NormalizedFilePath
f -> do
    HAR{hieKind :: ()
hieKind=HieKind a
kind, refMap :: ()
refMap=RefMap a
rm} <- forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetHieAst
GetHieAst NormalizedFilePath
f
    case HieKind a
kind of
      HieKind a
HieFresh      -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ RefMap Type -> Bindings
bindings RefMap a
rm)
      HieFromDisk HieFile
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], forall a. Maybe a
Nothing)

getDocMapRule :: Recorder (WithPriority Log) -> Rules ()
getDocMapRule :: Recorder (WithPriority Log) -> Rules ()
getDocMapRule Recorder (WithPriority Log)
recorder =
    forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \GetDocMap
GetDocMap NormalizedFilePath
file -> do
      -- Stale data for the scenario where a broken module has previously typechecked
      -- but we never generated a DocMap for it
      (TcModuleResult -> TcGblEnv
tmrTypechecked -> TcGblEnv
tc, PositionMapping
_) <- forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (v, PositionMapping)
useWithStale_ TypeCheck
TypeCheck NormalizedFilePath
file
      (HscEnvEq -> HscEnv
hscEnv -> HscEnv
hsc, PositionMapping
_)        <- forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (v, PositionMapping)
useWithStale_ GhcSessionDeps
GhcSessionDeps NormalizedFilePath
file
      (HAR{refMap :: ()
refMap=RefMap a
rf}, PositionMapping
_)       <- forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (v, PositionMapping)
useWithStale_ GetHieAst
GetHieAst NormalizedFilePath
file

      DocAndKindMap
dkMap <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. HscEnv -> RefMap a -> TcGblEnv -> IO DocAndKindMap
mkDocMap HscEnv
hsc RefMap a
rf TcGblEnv
tc
      forall (m :: * -> *) a. Monad m => a -> m a
return ([],forall a. a -> Maybe a
Just DocAndKindMap
dkMap)

-- | Persistent rule to ensure that hover doesn't block on startup
persistentDocMapRule :: Rules ()
persistentDocMapRule :: Rules ()
persistentDocMapRule = forall k v.
IdeRule k v =>
k
-> (NormalizedFilePath
    -> IdeAction (Maybe (v, PositionDelta, Maybe Int32)))
-> Rules ()
addPersistentRule GetDocMap
GetDocMap forall a b. (a -> b) -> a -> b
$ \NormalizedFilePath
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (DocMap -> KindMap -> DocAndKindMap
DKMap forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty, PositionDelta
idDelta, forall a. Maybe a
Nothing)

readHieFileForSrcFromDisk :: Recorder (WithPriority Log) -> NormalizedFilePath -> MaybeT IdeAction Compat.HieFile
readHieFileForSrcFromDisk :: Recorder (WithPriority Log)
-> NormalizedFilePath -> MaybeT IdeAction HieFile
readHieFileForSrcFromDisk Recorder (WithPriority Log)
recorder NormalizedFilePath
file = do
  ShakeExtras{WithHieDb
$sel:withHieDb:ShakeExtras :: ShakeExtras -> WithHieDb
withHieDb :: WithHieDb
withHieDb} <- forall r (m :: * -> *). MonadReader r m => m r
ask
  HieModuleRow
row <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ WithHieDb
withHieDb (\HieDb
hieDb -> HieDb -> [Char] -> IO (Maybe HieModuleRow)
HieDb.lookupHieFileFromSource HieDb
hieDb forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
file)
  let hie_loc :: [Char]
hie_loc = HieModuleRow -> [Char]
HieDb.hieModuleHieFile HieModuleRow
row
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Logger.Debug forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Log
LogLoadingHieFile NormalizedFilePath
file
  forall (m :: * -> *) e a. Functor m => ExceptT e m a -> MaybeT m a
exceptToMaybeT forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log)
-> [Char] -> ExceptT SomeException IdeAction HieFile
readHieFileFromDisk Recorder (WithPriority Log)
recorder [Char]
hie_loc

readHieFileFromDisk :: Recorder (WithPriority Log) -> FilePath -> ExceptT SomeException IdeAction Compat.HieFile
readHieFileFromDisk :: Recorder (WithPriority Log)
-> [Char] -> ExceptT SomeException IdeAction HieFile
readHieFileFromDisk Recorder (WithPriority Log)
recorder [Char]
hie_loc = do
  IORef NameCache
nc <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ShakeExtras -> IORef NameCache
ideNc
  Either SomeException HieFile
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either SomeException a)
tryAny forall a b. (a -> b) -> a -> b
$ NameCacheUpdater -> [Char] -> IO HieFile
loadHieFile (IORef NameCache -> NameCacheUpdater
mkUpdater IORef NameCache
nc) [Char]
hie_loc
  case Either SomeException HieFile
res of
    Left SomeException
e -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Logger.Debug forall a b. (a -> b) -> a -> b
$ [Char] -> SomeException -> Log
LogLoadingHieFileFail [Char]
hie_loc SomeException
e
    Right HieFile
_ -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Logger.Debug forall a b. (a -> b) -> a -> b
$ [Char] -> Log
LogLoadingHieFileSuccess [Char]
hie_loc
  forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except Either SomeException HieFile
res

-- | Typechecks a module.
typeCheckRule :: Recorder (WithPriority Log) -> Rules ()
typeCheckRule :: Recorder (WithPriority Log) -> Rules ()
typeCheckRule Recorder (WithPriority Log)
recorder = forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \TypeCheck
TypeCheck NormalizedFilePath
file -> do
    ParsedModule
pm <- forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetParsedModule
GetParsedModule NormalizedFilePath
file
    HscEnv
hsc  <- HscEnvEq -> HscEnv
hscEnv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GhcSessionDeps
GhcSessionDeps NormalizedFilePath
file
    IsFileOfInterestResult
foi <- forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ IsFileOfInterest
IsFileOfInterest NormalizedFilePath
file
    -- We should only call the typecheck rule for files of interest.
    -- Keeping typechecked modules in memory for other files is
    -- very expensive.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IsFileOfInterestResult
foi forall a. Eq a => a -> a -> Bool
== IsFileOfInterestResult
NotFOI) forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Logger.Warning forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Log
LogTypecheckedFOI NormalizedFilePath
file
    HscEnv -> ParsedModule -> Action (IdeResult TcModuleResult)
typeCheckRuleDefinition HscEnv
hsc ParsedModule
pm

knownFilesRule :: Recorder (WithPriority Log) -> Rules ()
knownFilesRule :: Recorder (WithPriority Log) -> Rules ()
knownFilesRule Recorder (WithPriority Log)
recorder = forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> Action (ByteString, v)) -> Rules ()
defineEarlyCutOffNoFile (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \GetKnownTargets
GetKnownTargets -> do
  Action ()
alwaysRerun
  Hashed KnownTargets
fs <- Action (Hashed KnownTargets)
knownTargets
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> ByteString
LBS.toStrict forall a b. (a -> b) -> a -> b
$ forall a. Binary a => a -> ByteString
B.encode forall a b. (a -> b) -> a -> b
$ forall a. Hashable a => a -> Int
hash Hashed KnownTargets
fs, forall a. Hashed a -> a
unhashed Hashed KnownTargets
fs)

getModuleGraphRule :: Recorder (WithPriority Log) -> Rules ()
getModuleGraphRule :: Recorder (WithPriority Log) -> Rules ()
getModuleGraphRule Recorder (WithPriority Log)
recorder = forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> Action (ByteString, v)) -> Rules ()
defineEarlyCutOffNoFile (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \GetModuleGraph
GetModuleGraph -> do
  HashSet NormalizedFilePath
fs <- KnownTargets -> HashSet NormalizedFilePath
toKnownFiles forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. IdeRule k v => k -> Action v
useNoFile_ GetKnownTargets
GetKnownTargets
  [NormalizedFilePath] -> Action (ByteString, DependencyInformation)
dependencyInfoForFiles (forall a. HashSet a -> [a]
HashSet.toList HashSet NormalizedFilePath
fs)

dependencyInfoForFiles :: [NormalizedFilePath] -> Action (BS.ByteString, DependencyInformation)
dependencyInfoForFiles :: [NormalizedFilePath] -> Action (ByteString, DependencyInformation)
dependencyInfoForFiles [NormalizedFilePath]
fs = do
  (RawDependencyInformation
rawDepInfo, BootIdMap
bm) <- [NormalizedFilePath]
-> Action (RawDependencyInformation, BootIdMap)
rawDependencyInformation [NormalizedFilePath]
fs
  let ([NormalizedFilePath]
all_fs, [FilePathId]
_all_ids) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> [(k, v)]
HM.toList forall a b. (a -> b) -> a -> b
$ PathIdMap -> HashMap NormalizedFilePath FilePathId
pathToIdMap forall a b. (a -> b) -> a -> b
$ RawDependencyInformation -> PathIdMap
rawPathIdMap RawDependencyInformation
rawDepInfo
  [Maybe ModSummaryResult]
msrs <- forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses GetModSummaryWithoutTimestamps
GetModSummaryWithoutTimestamps [NormalizedFilePath]
all_fs
  let mss :: [Maybe ModSummary]
mss = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ModSummaryResult -> ModSummary
msrModSummary) [Maybe ModSummaryResult]
msrs
#if MIN_VERSION_ghc(9,3,0)
  let deps = map (\i -> IM.lookup (getFilePathId i) (rawImports rawDepInfo)) _all_ids
      nodeKeys = IM.fromList $ catMaybes $ zipWith (\fi mms -> (getFilePathId fi,) . NodeKey_Module . msKey <$> mms) _all_ids mss
      mns = catMaybes $ zipWith go mss deps
      go (Just ms) (Just (Right (ModuleImports xs))) = Just $ ModuleNode this_dep_keys ms
        where this_dep_ids = mapMaybe snd xs
              this_dep_keys = mapMaybe (\fi -> IM.lookup (getFilePathId fi) nodeKeys) this_dep_ids
      go (Just ms) _ = Just $ ModuleNode [] ms
      go _ _ = Nothing
      mg = mkModuleGraph mns
#else
  let mg :: ModuleGraph
mg = [ExtendedModSummary] -> ModuleGraph
mkModuleGraph forall a b. (a -> b) -> a -> b
$
        -- We don't do any instantiation for backpack at this point of time, so it is OK to use
        -- 'extendModSummaryNoDeps'.
        -- This may have to change in the future.
          forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ExtendedModSummary
extendModSummaryNoDeps forall a b. (a -> b) -> a -> b
$
          (forall a. [Maybe a] -> [a]
catMaybes [Maybe ModSummary]
mss)
#endif
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Fingerprint -> ByteString
fingerprintToBS forall a b. (a -> b) -> a -> b
$ [Fingerprint] -> Fingerprint
Util.fingerprintFingerprints forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Fingerprint
fingerprint0 ModSummaryResult -> Fingerprint
msrFingerprint) [Maybe ModSummaryResult]
msrs, RawDependencyInformation
-> BootIdMap -> ModuleGraph -> DependencyInformation
processDependencyInformation RawDependencyInformation
rawDepInfo BootIdMap
bm ModuleGraph
mg)

-- This is factored out so it can be directly called from the GetModIface
-- rule. Directly calling this rule means that on the initial load we can
-- garbage collect all the intermediate typechecked modules rather than
-- retain the information forever in the shake graph.
typeCheckRuleDefinition
    :: HscEnv
    -> ParsedModule
    -> Action (IdeResult TcModuleResult)
typeCheckRuleDefinition :: HscEnv -> ParsedModule -> Action (IdeResult TcModuleResult)
typeCheckRuleDefinition HscEnv
hsc ParsedModule
pm = do
  Priority -> Action ()
setPriority Priority
priorityTypeCheck
  IdeOptions { optDefer :: IdeOptions -> IdeDefer
optDefer = IdeDefer
defer } <- Action IdeOptions
getIdeOptions

  UnliftIO Action
unlift <- forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
  let dets :: TypecheckHelpers
dets = TypecheckHelpers
           { getLinkables :: [NormalizedFilePath] -> IO [LinkableResult]
getLinkables = forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO Action
unlift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f v)
uses_ GetLinkable
GetLinkable
           }
  forall a.
Action (a, Maybe TcModuleResult)
-> Action (a, Maybe TcModuleResult)
addUsageDependencies forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    IdeDefer
-> HscEnv
-> TypecheckHelpers
-> ParsedModule
-> IO (IdeResult TcModuleResult)
typecheckModule IdeDefer
defer HscEnv
hsc TypecheckHelpers
dets ParsedModule
pm
  where
    addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult)
    addUsageDependencies :: forall a.
Action (a, Maybe TcModuleResult)
-> Action (a, Maybe TcModuleResult)
addUsageDependencies Action (a, Maybe TcModuleResult)
a = do
      r :: (a, Maybe TcModuleResult)
r@(a
_, Maybe TcModuleResult
mtc) <- Action (a, Maybe TcModuleResult)
a
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe TcModuleResult
mtc forall a b. (a -> b) -> a -> b
$ \TcModuleResult
tc -> do
        [[Char]]
used_files <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef forall a b. (a -> b) -> a -> b
$ TcGblEnv -> TcRef [[Char]]
tcg_dependent_files forall a b. (a -> b) -> a -> b
$ TcModuleResult -> TcGblEnv
tmrTypechecked TcModuleResult
tc
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f v)
uses_ GetModificationTime
GetModificationTime (forall a b. (a -> b) -> [a] -> [b]
map [Char] -> NormalizedFilePath
toNormalizedFilePath' [[Char]]
used_files)
      forall (m :: * -> *) a. Monad m => a -> m a
return (a, Maybe TcModuleResult)
r

-- | Get all the linkables stored in the graph, i.e. the ones we *do not* need to unload.
-- Doesn't actually contain the code, since we don't need it to unload
currentLinkables :: Action (ModuleEnv UTCTime)
currentLinkables :: Action (ModuleEnv UTCTime)
currentLinkables = do
    Var (ModuleEnv UTCTime)
compiledLinkables <- CompiledLinkables -> Var (ModuleEnv UTCTime)
getCompiledLinkables forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (HasCallStack, IsIdeGlobal a) => Action a
getIdeGlobalAction
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Var a -> IO a
readVar Var (ModuleEnv UTCTime)
compiledLinkables

loadGhcSession :: Recorder (WithPriority Log) -> GhcSessionDepsConfig -> Rules ()
loadGhcSession :: Recorder (WithPriority Log) -> GhcSessionDepsConfig -> Rules ()
loadGhcSession Recorder (WithPriority Log)
recorder GhcSessionDepsConfig
ghcSessionDepsConfig = do
    -- This function should always be rerun because it tracks changes
    -- to the version of the collection of HscEnv's.
    forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> Action (ByteString, v)) -> Rules ()
defineEarlyCutOffNoFile (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \GhcSessionIO
GhcSessionIO -> do
        Action ()
alwaysRerun
        IdeOptions
opts <- Action IdeOptions
getIdeOptions
        IdeGhcSession
res <- IdeOptions -> Action IdeGhcSession
optGhcSession IdeOptions
opts

        let fingerprint :: ByteString
fingerprint = ByteString -> ByteString
LBS.toStrict forall a b. (a -> b) -> a -> b
$ forall a. Binary a => a -> ByteString
B.encode forall a b. (a -> b) -> a -> b
$ forall a. Hashable a => a -> Int
hash (IdeGhcSession -> Int
sessionVersion IdeGhcSession
res)
        forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
fingerprint, IdeGhcSession
res)

    forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
defineEarlyCutoff (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v))
-> RuleBody k v
Rule forall a b. (a -> b) -> a -> b
$ \GhcSession
GhcSession NormalizedFilePath
file -> do
        IdeGhcSession{[Char] -> IO (IdeResult HscEnvEq, [[Char]])
loadSessionFun :: IdeGhcSession -> [Char] -> IO (IdeResult HscEnvEq, [[Char]])
loadSessionFun :: [Char] -> IO (IdeResult HscEnvEq, [[Char]])
loadSessionFun} <- forall k v. IdeRule k v => k -> Action v
useNoFile_ GhcSessionIO
GhcSessionIO
        (IdeResult HscEnvEq
val,[[Char]]
deps) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO (IdeResult HscEnvEq, [[Char]])
loadSessionFun forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
file

        -- add the deps to the Shake graph
        let addDependency :: [Char] -> Action ()
addDependency [Char]
fp = do
                -- VSCode uses absolute paths in its filewatch notifications
                [Char]
afp <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
makeAbsolute [Char]
fp
                let nfp :: NormalizedFilePath
nfp = [Char] -> NormalizedFilePath
toNormalizedFilePath' [Char]
afp
                Bool
itExists <- NormalizedFilePath -> Action Bool
getFileExists NormalizedFilePath
nfp
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
itExists forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ do
                  forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModificationTime
GetModificationTime NormalizedFilePath
nfp
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Char] -> Action ()
addDependency [[Char]]
deps

        let cutoffHash :: ByteString
cutoffHash = ByteString -> ByteString
LBS.toStrict forall a b. (a -> b) -> a -> b
$ forall a. Binary a => a -> ByteString
B.encode (forall a. Hashable a => a -> Int
hash (forall a b. (a, b) -> b
snd IdeResult HscEnvEq
val))
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just ByteString
cutoffHash, IdeResult HscEnvEq
val)

    forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ()
defineNoDiagnostics (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \(GhcSessionDeps_ Bool
fullModSummary) NormalizedFilePath
file -> do
        HscEnvEq
env <- forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GhcSession
GhcSession NormalizedFilePath
file
        Bool
-> GhcSessionDepsConfig
-> HscEnvEq
-> NormalizedFilePath
-> Action (Maybe HscEnvEq)
ghcSessionDepsDefinition Bool
fullModSummary GhcSessionDepsConfig
ghcSessionDepsConfig HscEnvEq
env NormalizedFilePath
file

newtype GhcSessionDepsConfig = GhcSessionDepsConfig
    { GhcSessionDepsConfig -> Bool
fullModuleGraph :: Bool
    }
instance Default GhcSessionDepsConfig where
  def :: GhcSessionDepsConfig
def = GhcSessionDepsConfig
    { $sel:fullModuleGraph:GhcSessionDepsConfig :: Bool
fullModuleGraph = Bool
True
    }

-- | Note [GhcSessionDeps]
-- For a file 'Foo', GhcSessionDeps "Foo.hs" results in an HscEnv which includes
-- 1. HomeModInfo's (in the HUG/HPT) for all modules in the transitive closure of "Foo", **NOT** including "Foo" itself.
-- 2. ModSummary's (in the ModuleGraph) for all modules in the transitive closure of "Foo", including "Foo" itself.
-- 3. ModLocation's (in the FinderCache) all modules in the transitive closure of "Foo", including "Foo" itself.
ghcSessionDepsDefinition
    :: -- | full mod summary
        Bool ->
        GhcSessionDepsConfig -> HscEnvEq -> NormalizedFilePath -> Action (Maybe HscEnvEq)
ghcSessionDepsDefinition :: Bool
-> GhcSessionDepsConfig
-> HscEnvEq
-> NormalizedFilePath
-> Action (Maybe HscEnvEq)
ghcSessionDepsDefinition Bool
fullModSummary GhcSessionDepsConfig{Bool
fullModuleGraph :: Bool
$sel:fullModuleGraph:GhcSessionDepsConfig :: GhcSessionDepsConfig -> Bool
..} HscEnvEq
env NormalizedFilePath
file = do
    let hsc :: HscEnv
hsc = HscEnvEq -> HscEnv
hscEnv HscEnvEq
env

    Maybe [NormalizedFilePath]
mbdeps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM(forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ArtifactsLocation -> NormalizedFilePath
artifactFilePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetLocatedImports
GetLocatedImports NormalizedFilePath
file
    case Maybe [NormalizedFilePath]
mbdeps of
        Maybe [NormalizedFilePath]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Just [NormalizedFilePath]
deps -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fullModuleGraph forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ ReportImportCycles
ReportImportCycles NormalizedFilePath
file
            ModSummary
ms <- ModSummaryResult -> ModSummary
msrModSummary forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if Bool
fullModSummary
                then forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModSummary
GetModSummary NormalizedFilePath
file
                else forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModSummaryWithoutTimestamps
GetModSummaryWithoutTimestamps NormalizedFilePath
file

            [HscEnv]
depSessions <- forall a b. (a -> b) -> [a] -> [b]
map HscEnvEq -> HscEnv
hscEnv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f v)
uses_ (Bool -> GhcSessionDeps
GhcSessionDeps_ Bool
fullModSummary) [NormalizedFilePath]
deps
            [HiFileResult]
ifaces <- forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f v)
uses_ GetModIface
GetModIface [NormalizedFilePath]
deps
            let inLoadOrder :: [HomeModInfo]
inLoadOrder = forall a b. (a -> b) -> [a] -> [b]
map (\HiFileResult{Maybe (CoreFile, ByteString)
ByteString
ModIface
ModSummary
ModDetails
ModuleEnv ByteString
hirCoreFp :: HiFileResult -> Maybe (CoreFile, ByteString)
hirRuntimeModules :: HiFileResult -> ModuleEnv ByteString
hirIfaceFp :: HiFileResult -> ByteString
hirModDetails :: HiFileResult -> ModDetails
hirModIface :: HiFileResult -> ModIface
hirModSummary :: HiFileResult -> ModSummary
hirCoreFp :: Maybe (CoreFile, ByteString)
hirRuntimeModules :: ModuleEnv ByteString
hirIfaceFp :: ByteString
hirModDetails :: ModDetails
hirModIface :: ModIface
hirModSummary :: ModSummary
..} -> ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
hirModIface ModDetails
hirModDetails Maybe Linkable
emptyHomeModInfoLinkable) [HiFileResult]
ifaces
            ModuleGraph
mg <- do
              if Bool
fullModuleGraph
              then DependencyInformation -> ModuleGraph
depModuleGraph forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. IdeRule k v => k -> Action v
useNoFile_ GetModuleGraph
GetModuleGraph
              else do
                let mgs :: [ModuleGraph]
mgs = forall a b. (a -> b) -> [a] -> [b]
map HscEnv -> ModuleGraph
hsc_mod_graph [HscEnv]
depSessions
#if MIN_VERSION_ghc(9,3,0)
                -- On GHC 9.4+, the module graph contains not only ModSummary's but each `ModuleNode` in the graph
                -- also points to all the direct descendants of the current module. To get the keys for the descendants
                -- we must get their `ModSummary`s
                !final_deps <- do
                  dep_mss <- map msrModSummary <$> uses_ GetModSummaryWithoutTimestamps deps
                  return $!! map (NodeKey_Module . msKey) dep_mss
                let module_graph_nodes =
                      nubOrdOn mkNodeKey (ModuleNode final_deps ms : concatMap mgModSummaries' mgs)
#else
                let module_graph_nodes :: [ExtendedModSummary]
module_graph_nodes =
                      -- We don't do any instantiation for backpack at this point of time, so it is OK to use
                      -- 'extendModSummaryNoDeps'.
                      -- This may have to change in the future.
                      forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ExtendedModSummary
extendModSummaryNoDeps forall a b. (a -> b) -> a -> b
$
                      forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn ModSummary -> Module
ms_mod (ModSummary
ms forall a. a -> [a] -> [a]
: forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ModuleGraph -> [ModSummary]
mgModSummaries [ModuleGraph]
mgs)
#endif
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. NFData1 f => (a -> ()) -> f a -> ()
liftRnf forall a. a -> ()
rwhnf [ExtendedModSummary]
module_graph_nodes
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [ExtendedModSummary] -> ModuleGraph
mkModuleGraph [ExtendedModSummary]
module_graph_nodes
            HscEnv
session' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> ModuleGraph
-> ModSummary
-> [HomeModInfo]
-> [HscEnv]
-> IO HscEnv
mergeEnvs HscEnv
hsc ModuleGraph
mg ModSummary
ms [HomeModInfo]
inLoadOrder [HscEnv]
depSessions

            -- Here we avoid a call to to `newHscEnvEqWithImportPaths`, which creates a new
            -- ExportsMap when it is called. We only need to create the ExportsMap once per
            -- session, while `ghcSessionDepsDefinition` will be called for each file we need
            -- to compile. `updateHscEnvEq` will refresh the HscEnv (session') and also
            -- generate a new Unique.
            forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnvEq -> HscEnv -> IO HscEnvEq
updateHscEnvEq HscEnvEq
env HscEnv
session')

-- | Load a iface from disk, or generate it if there isn't one or it is out of date
-- This rule also ensures that the `.hie` and `.o` (if needed) files are written out.
getModIfaceFromDiskRule :: Recorder (WithPriority Log) -> Rules ()
getModIfaceFromDiskRule :: Recorder (WithPriority Log) -> Rules ()
getModIfaceFromDiskRule Recorder (WithPriority Log)
recorder = forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
defineEarlyCutoff (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ forall k v.
(k
 -> NormalizedFilePath
 -> Value v
 -> Action (Maybe ByteString, IdeResult v))
-> RuleBody k v
RuleWithOldValue forall a b. (a -> b) -> a -> b
$ \GetModIfaceFromDisk
GetModIfaceFromDisk NormalizedFilePath
f Value HiFileResult
old -> do
  ModSummary
ms <- ModSummaryResult -> ModSummary
msrModSummary forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModSummary
GetModSummary NormalizedFilePath
f
  Maybe HscEnvEq
mb_session <- forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GhcSessionDeps
GhcSessionDeps NormalizedFilePath
f
  case Maybe HscEnvEq
mb_session of
    Maybe HscEnvEq
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, ([], forall a. Maybe a
Nothing))
    Just HscEnvEq
session -> do
      Maybe LinkableType
linkableType <- NormalizedFilePath -> Action (Maybe LinkableType)
getLinkableType NormalizedFilePath
f
      FileVersion
ver <- forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModificationTime
GetModificationTime NormalizedFilePath
f
      let m_old :: Maybe (HiFileResult, FileVersion)
m_old = case Value HiFileResult
old of
            Shake.Succeeded (Just FileVersion
old_version) HiFileResult
v -> forall a. a -> Maybe a
Just (HiFileResult
v, FileVersion
old_version)
            Shake.Stale Maybe PositionDelta
_   (Just FileVersion
old_version) HiFileResult
v -> forall a. a -> Maybe a
Just (HiFileResult
v, FileVersion
old_version)
            Value HiFileResult
_ -> forall a. Maybe a
Nothing
          recompInfo :: RecompilationInfo Action
recompInfo = RecompilationInfo
            { source_version :: FileVersion
source_version = FileVersion
ver
            , old_value :: Maybe (HiFileResult, FileVersion)
old_value = Maybe (HiFileResult, FileVersion)
m_old
            , get_file_version :: NormalizedFilePath -> Action (Maybe FileVersion)
get_file_version = forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetModificationTime_{missingFileDiagnostics :: Bool
missingFileDiagnostics = Bool
False}
            , get_linkable_hashes :: [NormalizedFilePath] -> Action [ByteString]
get_linkable_hashes = \[NormalizedFilePath]
fs -> forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. HiFileResult -> Maybe (CoreFile, ByteString)
hirCoreFp) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f v)
uses_ GetModIface
GetModIface [NormalizedFilePath]
fs
            , regenerate :: Maybe LinkableType -> Action (IdeResult HiFileResult)
regenerate = HscEnvEq
-> NormalizedFilePath
-> ModSummary
-> Maybe LinkableType
-> Action (IdeResult HiFileResult)
regenerateHiFile HscEnvEq
session NormalizedFilePath
f ModSummary
ms
            }
      IdeResult HiFileResult
r <- forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
HscEnv
-> ModSummary
-> Maybe LinkableType
-> RecompilationInfo m
-> m (IdeResult HiFileResult)
loadInterface (HscEnvEq -> HscEnv
hscEnv HscEnvEq
session) ModSummary
ms Maybe LinkableType
linkableType RecompilationInfo Action
recompInfo
      case IdeResult HiFileResult
r of
        ([FileDiagnostic]
diags, Maybe HiFileResult
Nothing) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, ([FileDiagnostic]
diags, forall a. Maybe a
Nothing))
        ([FileDiagnostic]
diags, Just HiFileResult
x) -> do
          let !fp :: Maybe ByteString
fp = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! HiFileResult -> ByteString
hiFileFingerPrint HiFileResult
x
          forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString
fp, ([FileDiagnostic]
diags, forall a. a -> Maybe a
Just HiFileResult
x))

-- | Check state of hiedb after loading an iface from disk - have we indexed the corresponding `.hie` file?
-- This function is responsible for ensuring database consistency
-- Whenever we read a `.hi` file, we must check to ensure we have also
-- indexed the corresponding `.hie` file. If this is not the case (for example,
-- `ghcide` could be killed before indexing finishes), we must re-index the
-- `.hie` file. There should be an up2date `.hie` file on
-- disk since we are careful to write out the `.hie` file before writing the
-- `.hi` file
getModIfaceFromDiskAndIndexRule :: Recorder (WithPriority Log) -> Rules ()
getModIfaceFromDiskAndIndexRule :: Recorder (WithPriority Log) -> Rules ()
getModIfaceFromDiskAndIndexRule Recorder (WithPriority Log)
recorder =
  -- doesn't need early cutoff since all its dependencies already have it
  forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ()
defineNoDiagnostics (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \GetModIfaceFromDiskAndIndex
GetModIfaceFromDiskAndIndex NormalizedFilePath
f -> do
  HiFileResult
x <- forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModIfaceFromDisk
GetModIfaceFromDisk NormalizedFilePath
f
  se :: ShakeExtras
se@ShakeExtras{WithHieDb
withHieDb :: WithHieDb
$sel:withHieDb:ShakeExtras :: ShakeExtras -> WithHieDb
withHieDb} <- Action ShakeExtras
getShakeExtras

  -- GetModIfaceFromDisk should have written a `.hie` file, must check if it matches version in db
  let ms :: ModSummary
ms = HiFileResult -> ModSummary
hirModSummary HiFileResult
x
      hie_loc :: [Char]
hie_loc = ModLocation -> [Char]
Compat.ml_hie_file forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location ModSummary
ms
  Fingerprint
fileHash <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Fingerprint
Util.getFileHash [Char]
hie_loc
  Maybe HieModuleRow
mrow <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ WithHieDb
withHieDb (\HieDb
hieDb -> HieDb -> [Char] -> IO (Maybe HieModuleRow)
HieDb.lookupHieFileFromSource HieDb
hieDb (NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
f))
  Maybe [Char]
hie_loc' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([Char] -> IO [Char]
makeAbsolute forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieModuleRow -> [Char]
HieDb.hieModuleHieFile) Maybe HieModuleRow
mrow
  case Maybe HieModuleRow
mrow of
    Just HieModuleRow
row
      | Fingerprint
fileHash forall a. Eq a => a -> a -> Bool
== ModuleInfo -> Fingerprint
HieDb.modInfoHash (HieModuleRow -> ModuleInfo
HieDb.hieModInfo HieModuleRow
row)
      Bool -> Bool -> Bool
&& forall a. a -> Maybe a
Just [Char]
hie_loc forall a. Eq a => a -> a -> Bool
== Maybe [Char]
hie_loc'
      -> do
      -- All good, the db has indexed the file
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ ShakeExtras -> IdeTesting
ideTesting ShakeExtras
se) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) c.
Applicative m =>
Maybe (LanguageContextEnv c) -> LspT c m () -> m ()
mRunLspT (ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv ShakeExtras
se) forall a b. (a -> b) -> a -> b
$
        forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification (forall {f :: MessageDirection} {t :: MessageKind} (s :: Symbol).
KnownSymbol s =>
Proxy s -> SMethod ('Method_CustomMethod s)
SMethod_CustomMethod (forall {k} (t :: k). Proxy t
Proxy @"ghcide/reference/ready")) forall a b. (a -> b) -> a -> b
$
          forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
f
    -- Not in db, must re-index
    Maybe HieModuleRow
_ -> do
      Either SomeException HieFile
ehf <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> ShakeExtras -> IdeAction a -> IO a
runIdeAction [Char]
"GetModIfaceFromDiskAndIndex" ShakeExtras
se forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$
        Recorder (WithPriority Log)
-> [Char] -> ExceptT SomeException IdeAction HieFile
readHieFileFromDisk Recorder (WithPriority Log)
recorder [Char]
hie_loc
      case Either SomeException HieFile
ehf of
        -- Uh oh, we failed to read the file for some reason, need to regenerate it
        Left SomeException
err -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"failed to read .hie file " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
hie_loc forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ forall e. Exception e => e -> [Char]
displayException SomeException
err
        -- can just re-index the file we read from disk
        Right HieFile
hf -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
          forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Logger.Debug forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Log
LogReindexingHieFile NormalizedFilePath
f
          ShakeExtras
-> ModSummary
-> NormalizedFilePath
-> Fingerprint
-> HieFile
-> IO ()
indexHieFile ShakeExtras
se ModSummary
ms NormalizedFilePath
f Fingerprint
fileHash HieFile
hf

  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just HiFileResult
x)

newtype DisplayTHWarning = DisplayTHWarning (IO())
instance IsIdeGlobal DisplayTHWarning

getModSummaryRule :: LspT Config IO () -> Recorder (WithPriority Log) -> Rules ()
getModSummaryRule :: LspT Config IO () -> Recorder (WithPriority Log) -> Rules ()
getModSummaryRule LspT Config IO ()
displayTHWarning Recorder (WithPriority Log)
recorder = do
    Maybe (LanguageContextEnv Config)
menv <- ShakeExtras -> Maybe (LanguageContextEnv Config)
lspEnv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rules ShakeExtras
getShakeExtrasRules
    case Maybe (LanguageContextEnv Config)
menv of
      Just LanguageContextEnv Config
env -> do
        IO ()
displayItOnce <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO (IO a)
once forall a b. (a -> b) -> a -> b
$ forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv Config
env LspT Config IO ()
displayTHWarning
        forall a. IsIdeGlobal a => a -> Rules ()
addIdeGlobal (IO () -> DisplayTHWarning
DisplayTHWarning IO ()
displayItOnce)
      Maybe (LanguageContextEnv Config)
Nothing -> do
        IO ()
logItOnce <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO (IO a)
once forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
""
        forall a. IsIdeGlobal a => a -> Rules ()
addIdeGlobal (IO () -> DisplayTHWarning
DisplayTHWarning IO ()
logItOnce)

    forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
defineEarlyCutoff (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v))
-> RuleBody k v
Rule forall a b. (a -> b) -> a -> b
$ \GetModSummary
GetModSummary NormalizedFilePath
f -> do
        HscEnv
session' <- HscEnvEq -> HscEnv
hscEnv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GhcSession
GhcSession NormalizedFilePath
f
        DynFlags -> DynFlags
modify_dflags <- forall a. (DynFlagsModifications -> a) -> Action a
getModifyDynFlags DynFlagsModifications -> DynFlags -> DynFlags
dynFlagsModifyGlobal
        let session :: HscEnv
session = DynFlags -> HscEnv -> HscEnv
hscSetFlags (DynFlags -> DynFlags
modify_dflags forall a b. (a -> b) -> a -> b
$ HscEnv -> DynFlags
hsc_dflags HscEnv
session') HscEnv
session'
        (UTCTime
modTime, Maybe Text
mFileContent) <- NormalizedFilePath -> Action (UTCTime, Maybe Text)
getFileContents NormalizedFilePath
f
        let fp :: [Char]
fp = NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
f
        Either [FileDiagnostic] ModSummaryResult
modS <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$
                HscEnv
-> [Char]
-> UTCTime
-> Maybe StringBuffer
-> ExceptT [FileDiagnostic] IO ModSummaryResult
getModSummaryFromImports HscEnv
session [Char]
fp UTCTime
modTime (Text -> StringBuffer
textToStringBuffer forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mFileContent)
        case Either [FileDiagnostic] ModSummaryResult
modS of
            Right ModSummaryResult
res -> do
                -- Check for Template Haskell
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ModSummary -> Bool
uses_th_qq forall a b. (a -> b) -> a -> b
$ ModSummaryResult -> ModSummary
msrModSummary ModSummaryResult
res) forall a b. (a -> b) -> a -> b
$ do
                    DisplayTHWarning IO ()
act <- forall a. (HasCallStack, IsIdeGlobal a) => Action a
getIdeGlobalAction
                    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
act
#if MIN_VERSION_ghc(9,3,0)
                let bufFingerPrint = ms_hs_hash (msrModSummary res)
#else
                Fingerprint
bufFingerPrint <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
                    StringBuffer -> IO Fingerprint
fingerprintFromStringBuffer forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ ModSummary -> Maybe StringBuffer
ms_hspp_buf forall a b. (a -> b) -> a -> b
$ ModSummaryResult -> ModSummary
msrModSummary ModSummaryResult
res
#endif
                let fingerPrint :: Fingerprint
fingerPrint = [Fingerprint] -> Fingerprint
Util.fingerprintFingerprints
                        [ ModSummaryResult -> Fingerprint
msrFingerprint ModSummaryResult
res, Fingerprint
bufFingerPrint ]
                forall (m :: * -> *) a. Monad m => a -> m a
return ( forall a. a -> Maybe a
Just (Fingerprint -> ByteString
fingerprintToBS Fingerprint
fingerPrint) , ([], forall a. a -> Maybe a
Just ModSummaryResult
res))
            Left [FileDiagnostic]
diags -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, ([FileDiagnostic]
diags, forall a. Maybe a
Nothing))

    forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
defineEarlyCutoff (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
RuleNoDiagnostics forall a b. (a -> b) -> a -> b
$ \GetModSummaryWithoutTimestamps
GetModSummaryWithoutTimestamps NormalizedFilePath
f -> do
        Maybe ModSummaryResult
mbMs <- forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetModSummary
GetModSummary NormalizedFilePath
f
        case Maybe ModSummaryResult
mbMs of
            Just res :: ModSummaryResult
res@ModSummaryResult{[LImportDecl GhcPs]
Fingerprint
HscEnv
ModSummary
msrImports :: ModSummaryResult -> [LImportDecl GhcPs]
msrHscEnv :: HscEnv
msrFingerprint :: Fingerprint
msrImports :: [LImportDecl GhcPs]
msrModSummary :: ModSummary
msrFingerprint :: ModSummaryResult -> Fingerprint
msrHscEnv :: ModSummaryResult -> HscEnv
msrModSummary :: ModSummaryResult -> ModSummary
..} -> do
                let ms :: ModSummary
ms = ModSummary
msrModSummary {
#if !MIN_VERSION_ghc(9,3,0)
                    ms_hs_date :: UTCTime
ms_hs_date = forall a. HasCallStack => [Char] -> a
error [Char]
"use GetModSummary instead of GetModSummaryWithoutTimestamps",
#endif
                    ms_hspp_buf :: Maybe StringBuffer
ms_hspp_buf = forall a. HasCallStack => [Char] -> a
error [Char]
"use GetModSummary instead of GetModSummaryWithoutTimestamps"
                    }
                    fp :: ByteString
fp = Fingerprint -> ByteString
fingerprintToBS Fingerprint
msrFingerprint
                forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just ByteString
fp, forall a. a -> Maybe a
Just ModSummaryResult
res{msrModSummary :: ModSummary
msrModSummary = ModSummary
ms})
            Maybe ModSummaryResult
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)

generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult ModGuts)
generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult ModGuts)
generateCore RunSimplifier
runSimplifier NormalizedFilePath
file = do
    HscEnv
packageState <- HscEnvEq -> HscEnv
hscEnv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GhcSessionDeps
GhcSessionDeps NormalizedFilePath
file
    TcModuleResult
tm <- forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ TypeCheck
TypeCheck NormalizedFilePath
file
    Priority -> Action ()
setPriority Priority
priorityGenerateCore
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ RunSimplifier
-> HscEnv -> ModSummary -> TcGblEnv -> IO (IdeResult ModGuts)
compileModule RunSimplifier
runSimplifier HscEnv
packageState (TcModuleResult -> ModSummary
tmrModSummary TcModuleResult
tm) (TcModuleResult -> TcGblEnv
tmrTypechecked TcModuleResult
tm)

generateCoreRule :: Recorder (WithPriority Log) -> Rules ()
generateCoreRule :: Recorder (WithPriority Log) -> Rules ()
generateCoreRule Recorder (WithPriority Log)
recorder =
    forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \GenerateCore
GenerateCore -> RunSimplifier -> NormalizedFilePath -> Action (IdeResult ModGuts)
generateCore (Bool -> RunSimplifier
RunSimplifier Bool
True)

getModIfaceRule :: Recorder (WithPriority Log) -> Rules ()
getModIfaceRule :: Recorder (WithPriority Log) -> Rules ()
getModIfaceRule Recorder (WithPriority Log)
recorder = forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
defineEarlyCutoff (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v))
-> RuleBody k v
Rule forall a b. (a -> b) -> a -> b
$ \GetModIface
GetModIface NormalizedFilePath
f -> do
  IsFileOfInterestResult
fileOfInterest <- forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ IsFileOfInterest
IsFileOfInterest NormalizedFilePath
f
  (Maybe ByteString, IdeResult HiFileResult)
res <- case IsFileOfInterestResult
fileOfInterest of
    IsFOI FileOfInterestStatus
status -> do
      -- Never load from disk for files of interest
      TcModuleResult
tmr <- forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ TypeCheck
TypeCheck NormalizedFilePath
f
      Maybe LinkableType
linkableType <- NormalizedFilePath -> Action (Maybe LinkableType)
getLinkableType NormalizedFilePath
f
      HscEnv
hsc <- HscEnvEq -> HscEnv
hscEnv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GhcSessionDeps
GhcSessionDeps NormalizedFilePath
f
      let compile :: Action (IdeResult ModGuts)
compile = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([],) forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GenerateCore
GenerateCore NormalizedFilePath
f
      ShakeExtras
se <- Action ShakeExtras
getShakeExtras
      ([FileDiagnostic]
diags, !Maybe HiFileResult
mbHiFile) <- ShakeExtras
-> HscEnv
-> Maybe LinkableType
-> Action (IdeResult ModGuts)
-> TcModuleResult
-> Action (IdeResult HiFileResult)
writeCoreFileIfNeeded ShakeExtras
se HscEnv
hsc Maybe LinkableType
linkableType Action (IdeResult ModGuts)
compile TcModuleResult
tmr
      let fp :: Maybe ByteString
fp = HiFileResult -> ByteString
hiFileFingerPrint forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe HiFileResult
mbHiFile
      [FileDiagnostic]
hiDiags <- case Maybe HiFileResult
mbHiFile of
        Just HiFileResult
hiFile
          | FileOfInterestStatus
OnDisk <- FileOfInterestStatus
status
          , Bool -> Bool
not (TcModuleResult -> Bool
tmrDeferredError TcModuleResult
tmr) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ShakeExtras -> HscEnv -> HiFileResult -> IO [FileDiagnostic]
writeHiFile ShakeExtras
se HscEnv
hsc HiFileResult
hiFile
        Maybe HiFileResult
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString
fp, ([FileDiagnostic]
diagsforall a. [a] -> [a] -> [a]
++[FileDiagnostic]
hiDiags, Maybe HiFileResult
mbHiFile))
    IsFileOfInterestResult
NotFOI -> do
      Maybe HiFileResult
hiFile <- forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetModIfaceFromDiskAndIndex
GetModIfaceFromDiskAndIndex NormalizedFilePath
f
      let fp :: Maybe ByteString
fp = HiFileResult -> ByteString
hiFileFingerPrint forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe HiFileResult
hiFile
      forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString
fp, ([], Maybe HiFileResult
hiFile))

  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString, IdeResult HiFileResult)
res

-- | Count of total times we asked GHC to recompile
newtype RebuildCounter = RebuildCounter { RebuildCounter -> TVar Int
getRebuildCountVar :: TVar Int }
instance IsIdeGlobal RebuildCounter

getRebuildCount :: Action Int
getRebuildCount :: Action Int
getRebuildCount = do
  TVar Int
count <- RebuildCounter -> TVar Int
getRebuildCountVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (HasCallStack, IsIdeGlobal a) => Action a
getIdeGlobalAction
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> IO a
readTVarIO TVar Int
count

incrementRebuildCount :: Action ()
incrementRebuildCount :: Action ()
incrementRebuildCount = do
  TVar Int
count <- RebuildCounter -> TVar Int
getRebuildCountVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (HasCallStack, IsIdeGlobal a) => Action a
getIdeGlobalAction
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
count (forall a. Num a => a -> a -> a
+Int
1)

-- | Also generates and indexes the `.hie` file, along with the `.o` file if needed
-- Invariant maintained is that if the `.hi` file was successfully written, then the
-- `.hie` and `.o` file (if needed) were also successfully written
regenerateHiFile :: HscEnvEq -> NormalizedFilePath -> ModSummary -> Maybe LinkableType -> Action ([FileDiagnostic], Maybe HiFileResult)
regenerateHiFile :: HscEnvEq
-> NormalizedFilePath
-> ModSummary
-> Maybe LinkableType
-> Action (IdeResult HiFileResult)
regenerateHiFile HscEnvEq
sess NormalizedFilePath
f ModSummary
ms Maybe LinkableType
compNeeded = do
    let hsc :: HscEnv
hsc = HscEnvEq -> HscEnv
hscEnv HscEnvEq
sess
    IdeOptions
opt <- Action IdeOptions
getIdeOptions

    -- Embed haddocks in the interface file
    ([FileDiagnostic]
diags, Maybe ParsedModule
mb_pm) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> IdeOptions
-> NormalizedFilePath
-> ModSummary
-> IO ([FileDiagnostic], Maybe ParsedModule)
getParsedModuleDefinition HscEnv
hsc IdeOptions
opt NormalizedFilePath
f (ModSummary -> ModSummary
withOptHaddock ModSummary
ms)
    ([FileDiagnostic]
diags', Maybe ParsedModule
mb_pm') <-
        -- We no longer need to parse again if GHC version is above 9.0. https://github.com/haskell/haskell-language-server/issues/1892
        if GhcVersion
Compat.ghcVersion forall a. Ord a => a -> a -> Bool
>= GhcVersion
Compat.GHC90 Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isJust Maybe ParsedModule
mb_pm then do
            forall (m :: * -> *) a. Monad m => a -> m a
return ([FileDiagnostic]
diags, Maybe ParsedModule
mb_pm)
        else do
            -- if parsing fails, try parsing again with Haddock turned off
            ([FileDiagnostic]
diagsNoHaddock, Maybe ParsedModule
mb_pm') <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> IdeOptions
-> NormalizedFilePath
-> ModSummary
-> IO ([FileDiagnostic], Maybe ParsedModule)
getParsedModuleDefinition HscEnv
hsc IdeOptions
opt NormalizedFilePath
f ModSummary
ms
            forall (m :: * -> *) a. Monad m => a -> m a
return ([FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic]
mergeParseErrorsHaddock [FileDiagnostic]
diagsNoHaddock [FileDiagnostic]
diags, Maybe ParsedModule
mb_pm')
    case Maybe ParsedModule
mb_pm' of
        Maybe ParsedModule
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ([FileDiagnostic]
diags', forall a. Maybe a
Nothing)
        Just ParsedModule
pm -> do
            -- Invoke typechecking directly to update it without incurring a dependency
            -- on the parsed module and the typecheck rules
            ([FileDiagnostic]
diags'', Maybe TcModuleResult
mtmr) <- HscEnv -> ParsedModule -> Action (IdeResult TcModuleResult)
typeCheckRuleDefinition HscEnv
hsc ParsedModule
pm
            case Maybe TcModuleResult
mtmr of
              Maybe TcModuleResult
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FileDiagnostic]
diags'', forall a. Maybe a
Nothing)
              Just TcModuleResult
tmr -> do

                let compile :: Action (IdeResult ModGuts)
compile = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ RunSimplifier
-> HscEnv -> ModSummary -> TcGblEnv -> IO (IdeResult ModGuts)
compileModule (Bool -> RunSimplifier
RunSimplifier Bool
True) HscEnv
hsc (ParsedModule -> ModSummary
pm_mod_summary ParsedModule
pm) forall a b. (a -> b) -> a -> b
$ TcModuleResult -> TcGblEnv
tmrTypechecked TcModuleResult
tmr

                ShakeExtras
se <- Action ShakeExtras
getShakeExtras

                -- Bang pattern is important to avoid leaking 'tmr'
                ([FileDiagnostic]
diags''', !Maybe HiFileResult
res) <- ShakeExtras
-> HscEnv
-> Maybe LinkableType
-> Action (IdeResult ModGuts)
-> TcModuleResult
-> Action (IdeResult HiFileResult)
writeCoreFileIfNeeded ShakeExtras
se HscEnv
hsc Maybe LinkableType
compNeeded Action (IdeResult ModGuts)
compile TcModuleResult
tmr

                -- Write hi file
                [FileDiagnostic]
hiDiags <- case Maybe HiFileResult
res of
                  Just !HiFileResult
hiFile -> do

                    -- Write hie file. Do this before writing the .hi file to
                    -- ensure that we always have a up2date .hie file if we have
                    -- a .hi file
                    ShakeExtras
se' <- Action ShakeExtras
getShakeExtras
                    ([FileDiagnostic]
gDiags, Maybe (HieASTs Type)
masts) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> TcModuleResult -> IO ([FileDiagnostic], Maybe (HieASTs Type))
generateHieAsts HscEnv
hsc TcModuleResult
tmr
                    ByteString
source <- NormalizedFilePath -> Action ByteString
getSourceFileSource NormalizedFilePath
f
                    Maybe [FileDiagnostic]
wDiags <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (HieASTs Type)
masts forall a b. (a -> b) -> a -> b
$ \HieASTs Type
asts ->
                      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> ShakeExtras
-> ModSummary
-> NormalizedFilePath
-> [AvailInfo]
-> HieASTs Type
-> ByteString
-> IO [FileDiagnostic]
writeAndIndexHieFile HscEnv
hsc ShakeExtras
se' (TcModuleResult -> ModSummary
tmrModSummary TcModuleResult
tmr) NormalizedFilePath
f (TcGblEnv -> [AvailInfo]
tcg_exports forall a b. (a -> b) -> a -> b
$ TcModuleResult -> TcGblEnv
tmrTypechecked TcModuleResult
tmr) HieASTs Type
asts ByteString
source

                    -- We don't write the `.hi` file if there are deferred errors, since we won't get
                    -- accurate diagnostics next time if we do
                    [FileDiagnostic]
hiDiags <- if Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ TcModuleResult -> Bool
tmrDeferredError TcModuleResult
tmr
                               then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ShakeExtras -> HscEnv -> HiFileResult -> IO [FileDiagnostic]
writeHiFile ShakeExtras
se' HscEnv
hsc HiFileResult
hiFile
                               else forall (f :: * -> *) a. Applicative f => a -> f a
pure []

                    forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FileDiagnostic]
hiDiags forall a. Semigroup a => a -> a -> a
<> [FileDiagnostic]
gDiags forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat Maybe [FileDiagnostic]
wDiags)
                  Maybe HiFileResult
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []

                forall (m :: * -> *) a. Monad m => a -> m a
return ([FileDiagnostic]
diags' forall a. Semigroup a => a -> a -> a
<> [FileDiagnostic]
diags'' forall a. Semigroup a => a -> a -> a
<> [FileDiagnostic]
diags''' forall a. Semigroup a => a -> a -> a
<> [FileDiagnostic]
hiDiags, Maybe HiFileResult
res)


-- | HscEnv should have deps included already
-- This writes the core file if a linkable is required
-- The actual linkable will be generated on demand when required by `GetLinkable`
writeCoreFileIfNeeded :: ShakeExtras -> HscEnv -> Maybe LinkableType -> Action (IdeResult ModGuts) -> TcModuleResult -> Action (IdeResult HiFileResult)
writeCoreFileIfNeeded :: ShakeExtras
-> HscEnv
-> Maybe LinkableType
-> Action (IdeResult ModGuts)
-> TcModuleResult
-> Action (IdeResult HiFileResult)
writeCoreFileIfNeeded ShakeExtras
_ HscEnv
hsc Maybe LinkableType
Nothing Action (IdeResult ModGuts)
_ TcModuleResult
tmr = do
  Action ()
incrementRebuildCount
  HiFileResult
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> TcModuleResult -> IO HiFileResult
mkHiFileResultNoCompile HscEnv
hsc TcModuleResult
tmr
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! HiFileResult
res)
writeCoreFileIfNeeded ShakeExtras
se HscEnv
hsc (Just LinkableType
_) Action (IdeResult ModGuts)
getGuts TcModuleResult
tmr = do
  Action ()
incrementRebuildCount
  ([FileDiagnostic]
diags, Maybe ModGuts
mguts) <- Action (IdeResult ModGuts)
getGuts
  case Maybe ModGuts
mguts of
    Maybe ModGuts
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FileDiagnostic]
diags, forall a. Maybe a
Nothing)
    Just ModGuts
guts -> do
      ([FileDiagnostic]
diags', !Maybe HiFileResult
res) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ShakeExtras
-> HscEnv
-> TcModuleResult
-> ModGuts
-> IO (IdeResult HiFileResult)
mkHiFileResultCompile ShakeExtras
se HscEnv
hsc TcModuleResult
tmr ModGuts
guts
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FileDiagnostic]
diagsforall a. [a] -> [a] -> [a]
++[FileDiagnostic]
diags', Maybe HiFileResult
res)

-- See Note [Client configuration in Rules]
getClientSettingsRule :: Recorder (WithPriority Log) -> Rules ()
getClientSettingsRule :: Recorder (WithPriority Log) -> Rules ()
getClientSettingsRule Recorder (WithPriority Log)
recorder = forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> Action (ByteString, v)) -> Rules ()
defineEarlyCutOffNoFile (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \GetClientSettings
GetClientSettings -> do
  Action ()
alwaysRerun
  Hashed (Maybe Value)
settings <- IdeConfiguration -> Hashed (Maybe Value)
clientSettings forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action IdeConfiguration
getIdeConfiguration
  forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ByteString
LBS.toStrict forall a b. (a -> b) -> a -> b
$ forall a. Binary a => a -> ByteString
B.encode forall a b. (a -> b) -> a -> b
$ forall a. Hashable a => a -> Int
hash Hashed (Maybe Value)
settings, Hashed (Maybe Value)
settings)

usePropertyAction ::
  (HasProperty s k t r) =>
  KeyNameProxy s ->
  PluginId ->
  Properties r ->
  Action (ToHsType t)
usePropertyAction :: forall (s :: Symbol) (k :: PropertyKey) (t :: PropertyType)
       (r :: [PropertyKey]).
HasProperty s k t r =>
KeyNameProxy s -> PluginId -> Properties r -> Action (ToHsType t)
usePropertyAction KeyNameProxy s
kn PluginId
plId Properties r
p = do
  PluginConfig
pluginConfig <- PluginId -> Action PluginConfig
getPluginConfigAction PluginId
plId
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (s :: Symbol) (k :: PropertyKey) (t :: PropertyType)
       (r :: [PropertyKey]).
HasProperty s k t r =>
KeyNameProxy s -> Properties r -> Object -> ToHsType t
useProperty KeyNameProxy s
kn Properties r
p forall a b. (a -> b) -> a -> b
$ PluginConfig -> Object
plcConfig PluginConfig
pluginConfig

-- ---------------------------------------------------------------------

getLinkableRule :: Recorder (WithPriority Log) -> Rules ()
getLinkableRule :: Recorder (WithPriority Log) -> Rules ()
getLinkableRule Recorder (WithPriority Log)
recorder =
  forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
defineEarlyCutoff (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ forall k v.
(k -> NormalizedFilePath -> Action (Maybe ByteString, IdeResult v))
-> RuleBody k v
Rule forall a b. (a -> b) -> a -> b
$ \GetLinkable
GetLinkable NormalizedFilePath
f -> do
    ModSummaryResult{msrModSummary :: ModSummaryResult -> ModSummary
msrModSummary = ModSummary
ms} <- forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModSummary
GetModSummary NormalizedFilePath
f
    HiFileResult{ModIface
hirModIface :: ModIface
hirModIface :: HiFileResult -> ModIface
hirModIface, ModDetails
hirModDetails :: ModDetails
hirModDetails :: HiFileResult -> ModDetails
hirModDetails, Maybe (CoreFile, ByteString)
hirCoreFp :: Maybe (CoreFile, ByteString)
hirCoreFp :: HiFileResult -> Maybe (CoreFile, ByteString)
hirCoreFp} <- forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetModIface
GetModIface NormalizedFilePath
f
    let obj_file :: [Char]
obj_file  = ModLocation -> [Char]
ml_obj_file (ModSummary -> ModLocation
ms_location ModSummary
ms)
        core_file :: [Char]
core_file = ModLocation -> [Char]
ml_core_file (ModSummary -> ModLocation
ms_location ModSummary
ms)
    -- Can't use `GetModificationTime` rule because the core file was possibly written in this
    -- very session, so the results aren't reliable
    POSIXTime
core_t <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO POSIXTime
getModTime [Char]
core_file
    case Maybe (CoreFile, ByteString)
hirCoreFp of
      Maybe (CoreFile, ByteString)
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"called GetLinkable for a file without a linkable"
      Just (CoreFile
bin_core, ByteString
fileHash) -> do
        HscEnvEq
session <- forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GhcSessionDeps
GhcSessionDeps NormalizedFilePath
f
        LinkableType
linkableType <- NormalizedFilePath -> Action (Maybe LinkableType)
getLinkableType NormalizedFilePath
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe LinkableType
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"called GetLinkable for a file which doesn't need compilation"
          Just LinkableType
t -> forall (f :: * -> *) a. Applicative f => a -> f a
pure LinkableType
t
        ([FileDiagnostic]
warns, Maybe HomeModInfo
hmi) <- case LinkableType
linkableType of
          -- Bytecode needs to be regenerated from the core file
          LinkableType
BCOLinkable -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ LinkableType
-> HscEnv
-> ModSummary
-> ModIface
-> ModDetails
-> CoreFile
-> UTCTime
-> IO ([FileDiagnostic], Maybe HomeModInfo)
coreFileToLinkable LinkableType
linkableType (HscEnvEq -> HscEnv
hscEnv HscEnvEq
session) ModSummary
ms ModIface
hirModIface ModDetails
hirModDetails CoreFile
bin_core (POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
core_t)
          -- Object code can be read from the disk
          LinkableType
ObjectLinkable -> do
            -- object file is up to date if it is newer than the core file
            -- Can't use a rule like 'GetModificationTime' or 'GetFileExists' because 'coreFileToLinkable' will write the object file, and
            -- thus bump its modification time, forcing this rule to be rerun every time.
            Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
doesFileExist [Char]
obj_file
            Maybe POSIXTime
mobj_time <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
              if Bool
exists
              then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO POSIXTime
getModTime [Char]
obj_file
              else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            case Maybe POSIXTime
mobj_time of
              Just POSIXTime
obj_t
                | POSIXTime
obj_t forall a. Ord a => a -> a -> Bool
>= POSIXTime
core_t -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
hirModIface ModDetails
hirModDetails (Linkable -> Maybe Linkable
justObjects forall a b. (a -> b) -> a -> b
$ UTCTime -> Module -> [Unlinked] -> Linkable
LM (POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
obj_t) (ModSummary -> Module
ms_mod ModSummary
ms) [[Char] -> Unlinked
DotO [Char]
obj_file]))
              Maybe POSIXTime
_ -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ LinkableType
-> HscEnv
-> ModSummary
-> ModIface
-> ModDetails
-> CoreFile
-> UTCTime
-> IO ([FileDiagnostic], Maybe HomeModInfo)
coreFileToLinkable LinkableType
linkableType (HscEnvEq -> HscEnv
hscEnv HscEnvEq
session) ModSummary
ms ModIface
hirModIface ModDetails
hirModDetails CoreFile
bin_core (forall a. HasCallStack => [Char] -> a
error [Char]
"object doesn't have time")
        -- Record the linkable so we know not to unload it, and unload old versions
        forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust ((HomeModInfo -> Maybe Linkable
homeModInfoByteCode forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe HomeModInfo
hmi) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (HomeModInfo -> Maybe Linkable
homeModInfoObject forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe HomeModInfo
hmi)) forall a b. (a -> b) -> a -> b
$ \(LM UTCTime
time Module
mod [Unlinked]
_) -> do
            Var (ModuleEnv UTCTime)
compiledLinkables <- CompiledLinkables -> Var (ModuleEnv UTCTime)
getCompiledLinkables forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (HasCallStack, IsIdeGlobal a) => Action a
getIdeGlobalAction
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var (ModuleEnv UTCTime)
compiledLinkables forall a b. (a -> b) -> a -> b
$ \ModuleEnv UTCTime
old -> do
              let !to_keep :: ModuleEnv UTCTime
to_keep = forall a. ModuleEnv a -> Module -> a -> ModuleEnv a
extendModuleEnv ModuleEnv UTCTime
old Module
mod UTCTime
time
              --We need to unload old linkables before we can load in new linkables. However,
              --the unload function in the GHC API takes a list of linkables to keep (i.e.
              --not unload). Earlier we unloaded right before loading in new linkables, which
              --is effectively once per splice. This can be slow as unload needs to walk over
              --the list of all loaded linkables, for each splice.
              --
              --Solution: now we unload old linkables right after we generate a new linkable and
              --just before returning it to be loaded. This has a substantial effect on recompile
              --times as the number of loaded modules and splices increases.
              --
              HscEnv -> [Linkable] -> IO ()
unload (HscEnvEq -> HscEnv
hscEnv HscEnvEq
session) (forall a b. (a -> b) -> [a] -> [b]
map (\(Module
mod', UTCTime
time') -> UTCTime -> Module -> [Unlinked] -> Linkable
LM UTCTime
time' Module
mod' []) forall a b. (a -> b) -> a -> b
$ forall a. ModuleEnv a -> [(Module, a)]
moduleEnvToList ModuleEnv UTCTime
to_keep)
              forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleEnv UTCTime
to_keep, ())
        forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
fileHash forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe HomeModInfo
hmi, ([FileDiagnostic]
warns, HomeModInfo -> ByteString -> LinkableResult
LinkableResult forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe HomeModInfo
hmi forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
fileHash))

-- | For now we always use bytecode unless something uses unboxed sums and tuples along with TH
getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType)
getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType)
getLinkableType NormalizedFilePath
f = forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ NeedsCompilation
NeedsCompilation NormalizedFilePath
f

-- needsCompilationRule :: Rules ()
needsCompilationRule :: NormalizedFilePath  -> Action (IdeResultNoDiagnosticsEarlyCutoff (Maybe LinkableType))
needsCompilationRule :: NormalizedFilePath
-> Action (IdeResultNoDiagnosticsEarlyCutoff (Maybe LinkableType))
needsCompilationRule NormalizedFilePath
file
  | [Char]
"boot" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` (NormalizedFilePath -> [Char]
fromNormalizedFilePath NormalizedFilePath
file) =
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Maybe LinkableType -> ByteString
encodeLinkableType forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just forall a. Maybe a
Nothing)
needsCompilationRule NormalizedFilePath
file = do
  Maybe DependencyInformation
graph <- forall k v. IdeRule k v => k -> Action (Maybe v)
useNoFile GetModuleGraph
GetModuleGraph
  Maybe LinkableType
res <- case Maybe DependencyInformation
graph of
    -- Treat as False if some reverse dependency header fails to parse
    Maybe DependencyInformation
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Just DependencyInformation
depinfo -> case NormalizedFilePath
-> DependencyInformation -> Maybe [NormalizedFilePath]
immediateReverseDependencies NormalizedFilePath
file DependencyInformation
depinfo of
      -- If we fail to get immediate reverse dependencies, fail with an error message
      Maybe [NormalizedFilePath]
Nothing -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Failed to get the immediate reverse dependencies of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show NormalizedFilePath
file
      Just [NormalizedFilePath]
revdeps -> do
        -- It's important to use stale data here to avoid wasted work.
        -- if NeedsCompilation fails for a module M its result will be  under-approximated
        -- to False in its dependencies. However, if M actually used TH, this will
        -- cause a re-evaluation of GetModIface for all dependencies
        -- (since we don't need to generate object code anymore).
        -- Once M is fixed we will discover that we actually needed all the object code
        -- that we just threw away, and thus have to recompile all dependencies once
        -- again, this time keeping the object code.
        -- A file needs to be compiled if any file that depends on it uses TemplateHaskell or needs to be compiled
        ModSummary
ms <- ModSummaryResult -> ModSummary
msrModSummary forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (v, PositionMapping)
useWithStale_ GetModSummaryWithoutTimestamps
GetModSummaryWithoutTimestamps NormalizedFilePath
file
        ([Maybe ModSummary]
modsums,[Maybe (Maybe LinkableType)]
needsComps) <- forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2
            (,) (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ModSummaryResult -> ModSummary
msrModSummary forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k
-> f NormalizedFilePath -> Action (f (Maybe (v, PositionMapping)))
usesWithStale GetModSummaryWithoutTimestamps
GetModSummaryWithoutTimestamps [NormalizedFilePath]
revdeps)
                (forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses NeedsCompilation
NeedsCompilation [NormalizedFilePath]
revdeps)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ModSummary
-> [Maybe ModSummary] -> [Maybe LinkableType] -> Maybe LinkableType
computeLinkableType ModSummary
ms [Maybe ModSummary]
modsums (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [Maybe (Maybe LinkableType)]
needsComps)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Maybe LinkableType -> ByteString
encodeLinkableType Maybe LinkableType
res, forall a. a -> Maybe a
Just Maybe LinkableType
res)
  where
    computeLinkableType :: ModSummary -> [Maybe ModSummary] -> [Maybe LinkableType] -> Maybe LinkableType
    computeLinkableType :: ModSummary
-> [Maybe ModSummary] -> [Maybe LinkableType] -> Maybe LinkableType
computeLinkableType ModSummary
this [Maybe ModSummary]
deps [Maybe LinkableType]
xs
      | forall a. a -> Maybe a
Just LinkableType
ObjectLinkable forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Maybe LinkableType]
xs     = forall a. a -> Maybe a
Just LinkableType
ObjectLinkable -- If any dependent needs object code, so do we
      | forall a. a -> Maybe a
Just LinkableType
BCOLinkable    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Maybe LinkableType]
xs     = forall a. a -> Maybe a
Just LinkableType
this_type      -- If any dependent needs bytecode, then we need to be compiled
      | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ModSummary -> Bool
uses_th_qq) [Maybe ModSummary]
deps = forall a. a -> Maybe a
Just LinkableType
this_type      -- If any dependent needs TH, then we need to be compiled
      | Bool
otherwise                         = forall a. Maybe a
Nothing             -- If none of these conditions are satisfied, we don't need to compile
      where
        this_type :: LinkableType
this_type = DynFlags -> LinkableType
computeLinkableTypeForDynFlags (ModSummary -> DynFlags
ms_hspp_opts ModSummary
this)

uses_th_qq :: ModSummary -> Bool
uses_th_qq :: ModSummary -> Bool
uses_th_qq (ModSummary -> DynFlags
ms_hspp_opts -> DynFlags
dflags) =
      Extension -> DynFlags -> Bool
xopt Extension
LangExt.TemplateHaskell DynFlags
dflags Bool -> Bool -> Bool
|| Extension -> DynFlags -> Bool
xopt Extension
LangExt.QuasiQuotes DynFlags
dflags

-- | How should we compile this module?
-- (assuming we do in fact need to compile it).
-- Depends on whether it uses unboxed tuples or sums
computeLinkableTypeForDynFlags :: DynFlags -> LinkableType
computeLinkableTypeForDynFlags :: DynFlags -> LinkableType
computeLinkableTypeForDynFlags DynFlags
d
          = LinkableType
BCOLinkable
  where -- unboxed_tuples_or_sums is only used in GHC < 9.2
        _unboxed_tuples_or_sums :: Bool
_unboxed_tuples_or_sums =
            Extension -> DynFlags -> Bool
xopt Extension
LangExt.UnboxedTuples DynFlags
d Bool -> Bool -> Bool
|| Extension -> DynFlags -> Bool
xopt Extension
LangExt.UnboxedSums DynFlags
d

-- | Tracks which linkables are current, so we don't need to unload them
newtype CompiledLinkables = CompiledLinkables { CompiledLinkables -> Var (ModuleEnv UTCTime)
getCompiledLinkables :: Var (ModuleEnv UTCTime) }
instance IsIdeGlobal CompiledLinkables

data RulesConfig = RulesConfig
    { -- | Share the computation for the entire module graph
      -- We usually compute the full module graph for the project
      -- and share it for all files.
      -- However, in large projects it might not be desirable to wait
      -- for computing the entire module graph before starting to
      -- typecheck a particular file.
      -- Disabling this drastically decreases sharing and is likely to
      -- increase memory usage if you have multiple files open
      -- Disabling this also disables checking for import cycles
      RulesConfig -> Bool
fullModuleGraph :: Bool
    -- | Disable TH for improved performance in large codebases
    , RulesConfig -> Bool
enableTemplateHaskell :: Bool
    -- | Warning to show when TH is not supported by the current HLS binary
    , RulesConfig -> LspT Config IO ()
templateHaskellWarning :: LspT Config IO ()
    }

instance Default RulesConfig where
    def :: RulesConfig
def = Bool -> Bool -> LspT Config IO () -> RulesConfig
RulesConfig Bool
True Bool
True forall c. LspT c IO ()
displayTHWarning
      where
        displayTHWarning :: LspT c IO ()
        displayTHWarning :: forall c. LspT c IO ()
displayTHWarning
            | Bool -> Bool
not Bool
isWindows Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
hostIsDynamic = do
                forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification SMethod 'Method_WindowShowMessage
SMethod_WindowShowMessage forall a b. (a -> b) -> a -> b
$
                    MessageType -> Text -> ShowMessageParams
ShowMessageParams MessageType
MessageType_Info Text
thWarningMessage
            | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()

thWarningMessage :: T.Text
thWarningMessage :: Text
thWarningMessage = [Text] -> Text
T.unwords
  [ Text
"This HLS binary does not support Template Haskell."
  , Text
"Follow the [instructions](" forall a. Semigroup a => a -> a -> a
<> Text
templateHaskellInstructions forall a. Semigroup a => a -> a -> a
<> Text
")"
  , Text
"to build an HLS binary with support for Template Haskell."
  ]

-- | A rule that wires per-file rules together
mainRule :: Recorder (WithPriority Log) -> RulesConfig -> Rules ()
mainRule :: Recorder (WithPriority Log) -> RulesConfig -> Rules ()
mainRule Recorder (WithPriority Log)
recorder RulesConfig{Bool
LspT Config IO ()
templateHaskellWarning :: LspT Config IO ()
enableTemplateHaskell :: Bool
fullModuleGraph :: Bool
$sel:templateHaskellWarning:RulesConfig :: RulesConfig -> LspT Config IO ()
$sel:enableTemplateHaskell:RulesConfig :: RulesConfig -> Bool
$sel:fullModuleGraph:RulesConfig :: RulesConfig -> Bool
..} = do
    Var (ModuleEnv UTCTime)
linkables <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (Var a)
newVar forall a. ModuleEnv a
emptyModuleEnv
    forall a. IsIdeGlobal a => a -> Rules ()
addIdeGlobal forall a b. (a -> b) -> a -> b
$ Var (ModuleEnv UTCTime) -> CompiledLinkables
CompiledLinkables Var (ModuleEnv UTCTime)
linkables
    TVar Int
rebuildCountVar <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (TVar a)
newTVarIO Int
0
    forall a. IsIdeGlobal a => a -> Rules ()
addIdeGlobal forall a b. (a -> b) -> a -> b
$ TVar Int -> RebuildCounter
RebuildCounter TVar Int
rebuildCountVar
    Recorder (WithPriority Log) -> Rules ()
getParsedModuleRule Recorder (WithPriority Log)
recorder
    Recorder (WithPriority Log) -> Rules ()
getParsedModuleWithCommentsRule Recorder (WithPriority Log)
recorder
    Recorder (WithPriority Log) -> Rules ()
getLocatedImportsRule Recorder (WithPriority Log)
recorder
    Recorder (WithPriority Log) -> Rules ()
reportImportCyclesRule Recorder (WithPriority Log)
recorder
    Recorder (WithPriority Log) -> Rules ()
typeCheckRule Recorder (WithPriority Log)
recorder
    Recorder (WithPriority Log) -> Rules ()
getDocMapRule Recorder (WithPriority Log)
recorder
    Recorder (WithPriority Log) -> GhcSessionDepsConfig -> Rules ()
loadGhcSession Recorder (WithPriority Log)
recorder forall a. Default a => a
def{Bool
fullModuleGraph :: Bool
$sel:fullModuleGraph:GhcSessionDepsConfig :: Bool
fullModuleGraph}
    Recorder (WithPriority Log) -> Rules ()
getModIfaceFromDiskRule Recorder (WithPriority Log)
recorder
    Recorder (WithPriority Log) -> Rules ()
getModIfaceFromDiskAndIndexRule Recorder (WithPriority Log)
recorder
    Recorder (WithPriority Log) -> Rules ()
getModIfaceRule Recorder (WithPriority Log)
recorder
    LspT Config IO () -> Recorder (WithPriority Log) -> Rules ()
getModSummaryRule LspT Config IO ()
templateHaskellWarning Recorder (WithPriority Log)
recorder
    Recorder (WithPriority Log) -> Rules ()
getModuleGraphRule Recorder (WithPriority Log)
recorder
    Recorder (WithPriority Log) -> Rules ()
knownFilesRule Recorder (WithPriority Log)
recorder
    Recorder (WithPriority Log) -> Rules ()
getClientSettingsRule Recorder (WithPriority Log)
recorder
    Recorder (WithPriority Log) -> Rules ()
getHieAstsRule Recorder (WithPriority Log)
recorder
    Recorder (WithPriority Log) -> Rules ()
getBindingsRule Recorder (WithPriority Log)
recorder
    -- This rule uses a custom newness check that relies on the encoding
    --  produced by 'encodeLinkable'. This works as follows:
    --   * <previous> -> <new>
    --   * ObjectLinkable -> BCOLinkable : the prev linkable can be reused,  signal "no change"
    --   * Object/BCO -> NoLinkable      : the prev linkable can be ignored, signal "no change"
    --   * otherwise                     : the prev linkable cannot be reused, signal "value has changed"
    if Bool
enableTemplateHaskell
      then forall k v.
IdeRule k v =>
Recorder (WithPriority Log) -> RuleBody k v -> Rules ()
defineEarlyCutoff (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ forall k v.
(ByteString -> ByteString -> Bool)
-> (k -> NormalizedFilePath -> Action (Maybe ByteString, Maybe v))
-> RuleBody k v
RuleWithCustomNewnessCheck forall a. Ord a => a -> a -> Bool
(<=) forall a b. (a -> b) -> a -> b
$ \NeedsCompilation
NeedsCompilation NormalizedFilePath
file ->
                NormalizedFilePath
-> Action (IdeResultNoDiagnosticsEarlyCutoff (Maybe LinkableType))
needsCompilationRule NormalizedFilePath
file
      else forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ()
defineNoDiagnostics (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \NeedsCompilation
NeedsCompilation NormalizedFilePath
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a. Maybe a
Nothing
    Recorder (WithPriority Log) -> Rules ()
generateCoreRule Recorder (WithPriority Log)
recorder
    Recorder (WithPriority Log) -> Rules ()
getImportMapRule Recorder (WithPriority Log)
recorder
    Recorder (WithPriority Log) -> Rules ()
persistentHieFileRule Recorder (WithPriority Log)
recorder
    Rules ()
persistentDocMapRule
    Rules ()
persistentImportMapRule
    Recorder (WithPriority Log) -> Rules ()
getLinkableRule Recorder (WithPriority Log)
recorder

-- | Get HieFile for haskell file on NormalizedFilePath
getHieFile :: NormalizedFilePath -> Action (Maybe HieFile)
getHieFile :: NormalizedFilePath -> Action (Maybe HieFile)
getHieFile NormalizedFilePath
nfp = forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
  HAR {HieASTs a
hieAst :: ()
hieAst :: HieASTs a
hieAst} <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetHieAst
GetHieAst NormalizedFilePath
nfp
  TcModuleResult
tmr <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use TypeCheck
TypeCheck NormalizedFilePath
nfp
  HscEnvEq
ghc <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GhcSession
GhcSession NormalizedFilePath
nfp
  ModSummaryResult
msr <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetModSummaryWithoutTimestamps
GetModSummaryWithoutTimestamps NormalizedFilePath
nfp
  ByteString
source <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Action ByteString
getSourceFileSource NormalizedFilePath
nfp
  let exports :: [AvailInfo]
exports = TcGblEnv -> [AvailInfo]
tcg_exports forall a b. (a -> b) -> a -> b
$ TcModuleResult -> TcGblEnv
tmrTypechecked TcModuleResult
tmr
  HieASTs Type
typedAst <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast HieASTs a
hieAst
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. HscEnv -> Hsc a -> IO a
runHsc (HscEnvEq -> HscEnv
hscEnv HscEnvEq
ghc) forall a b. (a -> b) -> a -> b
$ ModSummary
-> [AvailInfo] -> HieASTs Type -> ByteString -> Hsc HieFile
mkHieFile' (ModSummaryResult -> ModSummary
msrModSummary ModSummaryResult
msr) [AvailInfo]
exports HieASTs Type
typedAst ByteString
source