diff --git a/bench/lib/Experiments.hs b/bench/lib/Experiments.hs --- a/bench/lib/Experiments.hs +++ b/bench/lib/Experiments.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE PolyKinds #-} {-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-} module Experiments @@ -194,7 +195,7 @@ let edit :: TextDocumentContentChangeEvent =TextDocumentContentChangeEvent { _range = Just Range {_start = bottom, _end = bottom} , _rangeLength = Nothing, _text = t} - bottom = Position maxBoundUinteger 0 + bottom = Position maxBound 0 t = T.unlines ["" ,"holef :: [Int] -> [Int]" @@ -213,7 +214,7 @@ flip allM docs $ \DocumentPositions{..} -> do bottom <- pred . length . T.lines <$> documentContents doc diags <- getCurrentDiagnostics doc - case requireDiagnostic diags (DsError, (bottom, 8), "Found hole", Nothing) of + case requireDiagnostic diags (DsError, (fromIntegral bottom, 8), "Found hole", Nothing) of Nothing -> pure True Just _err -> pure False ) @@ -251,7 +252,7 @@ <*> option auto (long "timeout" <> value 60 <> help "timeout for waiting for a ghcide response") <*> ( Example "name" <$> (Right <$> packageP) - <*> (some moduleOption <|> pure ["Distribution/Simple.hs"]) + <*> (some moduleOption <|> pure ["src/Distribution/Simple.hs"]) <*> pure [] <|> Example "name" @@ -263,7 +264,7 @@ packageP = ExamplePackage <$> strOption (long "example-package-name" <> value "Cabal") - <*> option versionP (long "example-package-version" <> value (makeVersion [3,4,0,0])) + <*> option versionP (long "example-package-version" <> value (makeVersion [3,6,0,0])) pathP = strOption (long "example-path") versionP :: ReadM Version @@ -404,7 +405,7 @@ ++ ["--verbose" | verbose ?config] ++ ["--ot-memory-profiling" | Just _ <- [otMemoryProfiling ?config]] lspTestCaps = - fullCaps {_window = Just $ WindowClientCapabilities $ Just True} + fullCaps {_window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } conf = defaultConfig { logStdErr = verbose ?config, @@ -585,7 +586,7 @@ doc <- openDoc m "haskell" -- Setup the special positions used by the experiments - lastLine <- length . T.lines <$> documentContents doc + lastLine <- fromIntegral . length . T.lines <$> documentContents doc changeDoc doc [TextDocumentContentChangeEvent { _range = Just (Range (Position lastLine 0) (Position lastLine 0)) , _rangeLength = Nothing @@ -638,9 +639,9 @@ return res where loop pos - | _line pos >= lll = + | (fromIntegral $ _line pos) >= lll = return Nothing - | _character pos >= lengthOfLine (_line pos) = + | (fromIntegral $ _character pos) >= lengthOfLine (fromIntegral $ _line pos) = loop (nextLine pos) | otherwise = do checks <- checkDefinitions pos &&^ checkCompletions pos @@ -663,7 +664,3 @@ checkCompletions pos = not . null <$> getCompletions doc pos --- | We don't have a uinteger type yet. So hardcode the maxBound of uinteger, 2 ^ 31 - 1 --- as a constant. -maxBoundUinteger :: Int -maxBoundUinteger = 2147483647 diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -7,7 +7,7 @@ import Arguments (Arguments (..), getArguments) -import Control.Monad.Extra (unless, whenJust) +import Control.Monad.Extra (unless) import Data.Default (def) import Data.Version (showVersion) import Development.GitRev (gitHash) @@ -50,13 +50,17 @@ if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion - whenJust argsCwd IO.setCurrentDirectory + -- if user uses --cwd option we need to make this path absolute (and set the current directory to it) + argsCwd <- case argsCwd of + Nothing -> IO.getCurrentDirectory + Just root -> IO.setCurrentDirectory root >> IO.getCurrentDirectory let logPriority = if argsVerbose then Debug else Info arguments = if argsTesting then Main.testing else Main.defaultArguments logPriority Main.defaultMain arguments - {Main.argCommand = argsCommand + { Main.argsProjectRoot = Just argsCwd + , Main.argCommand = argsCommand ,Main.argsLogger = Main.argsLogger arguments <> pure telemetryLogger ,Main.argsRules = do diff --git a/ghcide.cabal b/ghcide.cabal --- a/ghcide.cabal +++ b/ghcide.cabal @@ -2,7 +2,7 @@ build-type: Simple category: Development name: ghcide -version: 1.5.0.1 +version: 1.6.0.0 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors @@ -13,7 +13,7 @@ A library for building Haskell IDE's on top of the GHC API. homepage: https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme bug-reports: https://github.com/haskell/haskell-language-server/issues -tested-with: GHC == 8.6.5 || == 8.8.3 || == 8.8.4 || == 8.10.5 || == 8.10.6 || == 8.10.7 || == 9.0.1 +tested-with: GHC == 8.6.5 || == 8.8.4 || == 8.10.6 || == 8.10.7 || == 9.0.1 || == 9.0.2 || == 9.2.1 extra-source-files: README.md CHANGELOG.md test/data/**/*.project test/data/**/*.cabal @@ -49,22 +49,23 @@ dependent-sum, dlist, exceptions, - -- we can't use >= 1.7.10 while we have to use hlint == 3.2.* - extra >= 1.7.4 && < 1.7.10, + extra >= 1.7.4, fuzzy, filepath, fingertree, + focus, ghc-exactprint, ghc-trace-events, Glob, haddock-library >= 1.8 && < 1.11, hashable, hie-compat ^>= 0.2.0.0, - hls-plugin-api ^>= 1.2.0.2, + hls-plugin-api ^>= 1.2.0.2 || ^>= 1.3, lens, + list-t, hiedb == 0.4.1.*, - lsp-types >= 1.3.0.1 && < 1.4, - lsp == 1.2.*, + lsp-types ^>= 1.4.0.1, + lsp ^>= 1.4.0.0 , monoid-subclasses, mtl, network-uri, @@ -72,15 +73,17 @@ parallel, prettyprinter-ansi-terminal, prettyprinter, + random, regex-tdfa >= 1.3.1.0, retrie, rope-utf16-splay, safe, safe-exceptions, - hls-graph ^>= 1.5.1, + hls-graph ^>= 1.6, sorted-list, sqlite-simple, stm, + stm-containers, syb, text, time, @@ -92,7 +95,6 @@ hslogger, Diff ^>=0.4.0, vector, - bytestring-encoding, opentelemetry >=0.6.1, heapsize ==0.3.*, unliftio, @@ -103,8 +105,8 @@ ghc-check >=0.5.0.4, ghc-paths, cryptohash-sha1 >=0.11.100 && <0.12, - hie-bios >= 0.7.1 && < 0.9.0, - implicit-hie-cradle >= 0.3.0.5 && < 0.4, + hie-bios >= 0.8 && < 0.9.0, + implicit-hie-cradle ^>= 0.3.0.5 || ^>= 0.5, base16-bytestring >=0.1.1 && <1.1 if os(windows) build-depends: @@ -114,7 +116,6 @@ unix default-extensions: - ApplicativeDo BangPatterns DeriveFunctor DeriveGeneric @@ -144,6 +145,7 @@ Development.IDE Development.IDE.Main Development.IDE.Core.Actions + Development.IDE.Main.HeapStats Development.IDE.Core.Debouncer Development.IDE.Core.FileStore Development.IDE.Core.IdeConfiguration @@ -160,6 +162,7 @@ Development.IDE.GHC.Compat Development.IDE.GHC.Compat.Core Development.IDE.GHC.Compat.Env + Development.IDE.GHC.Compat.ExactPrint Development.IDE.GHC.Compat.Iface Development.IDE.GHC.Compat.Logger Development.IDE.GHC.Compat.Outputable @@ -168,6 +171,7 @@ Development.IDE.GHC.Compat.Units Development.IDE.GHC.Compat.Util Development.IDE.Core.Compile + Development.IDE.GHC.Dump Development.IDE.GHC.Error Development.IDE.GHC.ExactPrint Development.IDE.GHC.Orphans @@ -183,6 +187,7 @@ Development.IDE.Spans.Documentation Development.IDE.Spans.AtPoint Development.IDE.Spans.LocalBindings + Development.IDE.Spans.Pragmas Development.IDE.Types.Diagnostics Development.IDE.Types.Exports Development.IDE.Types.HscEnvEq @@ -297,7 +302,8 @@ -rtsopts -- disable idle GC -- increase nursery size - "-with-rtsopts=-I0 -A128M" + -- Enable collection of heap statistics + "-with-rtsopts=-I0 -A128M -T" main-is: Main.hs build-depends: hiedb, @@ -381,16 +387,21 @@ hls-plugin-api, network-uri, lens, + list-t, lsp-test ^>= 0.14, optparse-applicative, process, QuickCheck, quickcheck-instances, + random, rope-utf16-splay, regex-tdfa ^>= 1.3.1, safe, safe-exceptions, shake, + sqlite-simple, + stm, + stm-containers, hls-graph, tasty, tasty-expected-failure, @@ -399,7 +410,7 @@ tasty-rerun, text, unordered-containers, - if (impl(ghc >= 8.6)) + if (impl(ghc >= 8.6) && impl(ghc < 9.2)) build-depends: record-dot-preprocessor, record-hasfield @@ -413,6 +424,7 @@ Experiments Experiments.Types Progress + HieDbRetry default-extensions: BangPatterns DeriveFunctor @@ -442,6 +454,7 @@ base, bytestring, containers, + data-default, directory, extra, filepath, diff --git a/session-loader/Development/IDE/Session.hs b/session-loader/Development/IDE/Session.hs --- a/session-loader/Development/IDE/Session.hs +++ b/session-loader/Development/IDE/Session.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-| @@ -11,6 +12,8 @@ ,setInitialDynFlags ,getHieDbLoc ,runWithDb + ,retryOnSqliteBusy + ,retryOnException ) where -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses @@ -41,7 +44,7 @@ import Data.Time.Clock import Data.Version import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Shake +import Development.IDE.Core.Shake hiding (withHieDb) import qualified Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Compat.Core hiding (Target, TargetFile, TargetModule, @@ -73,17 +76,21 @@ import System.Info import Control.Applicative (Alternative ((<|>))) -import Control.Exception (evaluate) import Data.Void -import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.Stats (atomically, modifyTVar', + readTVar, writeTVar) import Control.Concurrent.STM.TQueue +import Data.Foldable (for_) import qualified Data.HashSet as Set import Database.SQLite.Simple import Development.IDE.Core.Tracing (withTrace) +import Development.IDE.Types.Shake (WithHieDb) import HieDb.Create import HieDb.Types import HieDb.Utils +import System.Random (RandomGen) +import qualified System.Random as Random -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String @@ -164,28 +171,118 @@ mapM_ setUnsafeGlobalDynFlags dynFlags pure libdir +-- | If the action throws exception that satisfies predicate then we sleep for +-- a duration determined by the random exponential backoff formula, +-- `uniformRandom(0, min (maxDelay, (baseDelay * 2) ^ retryAttempt))`, and try +-- the action again for a maximum of `maxRetryCount` times. +-- `MonadIO`, `MonadCatch` are used as constraints because there are a few +-- HieDb functions that don't return IO values. +retryOnException + :: (MonadIO m, MonadCatch m, RandomGen g, Exception e) + => (e -> Maybe e) -- ^ only retry on exception if this predicate returns Just + -> Logger + -> Int -- ^ maximum backoff delay in microseconds + -> Int -- ^ base backoff delay in microseconds + -> Int -- ^ maximum number of times to retry + -> g -- ^ random number generator + -> m a -- ^ action that may throw exception + -> m a +retryOnException exceptionPred logger maxDelay !baseDelay !maxRetryCount rng action = do + result <- tryJust exceptionPred action + case result of + Left e + | maxRetryCount > 0 -> do + -- multiply by 2 because baseDelay is midpoint of uniform range + let newBaseDelay = min maxDelay (baseDelay * 2) + let (delay, newRng) = Random.randomR (0, newBaseDelay) rng + let newMaxRetryCount = maxRetryCount - 1 + liftIO $ do + logWarning logger $ "Retrying - " <> makeLogMsgComponentsText (Right delay) newMaxRetryCount e + threadDelay delay + retryOnException exceptionPred logger maxDelay newBaseDelay newMaxRetryCount newRng action + + | otherwise -> do + liftIO $ do + logWarning logger $ "Retries exhausted - " <> makeLogMsgComponentsText (Left baseDelay) maxRetryCount e + throwIO e + + Right b -> pure b + where + -- e.g. delay: 1010102, maximumDelay: 12010, maxRetryCount: 9, exception: SQLError { ... } + makeLogMsgComponentsText delay newMaxRetryCount e = + let + logMsgComponents = + [ either + (("base delay: " <>) . T.pack . show) + (("delay: " <>) . T.pack . show) + delay + , "maximumDelay: " <> T.pack (show maxDelay) + , "maxRetryCount: " <> T.pack (show newMaxRetryCount) + , "exception: " <> T.pack (show e)] + in + T.intercalate ", " logMsgComponents + +-- | in microseconds +oneSecond :: Int +oneSecond = 1000000 + +-- | in microseconds +oneMillisecond :: Int +oneMillisecond = 1000 + +-- | default maximum number of times to retry hiedb call +maxRetryCount :: Int +maxRetryCount = 10 + +retryOnSqliteBusy :: (MonadIO m, MonadCatch m, RandomGen g) + => Logger -> g -> m a -> m a +retryOnSqliteBusy logger rng action = + let isErrorBusy e + | SQLError{ sqlError = ErrorBusy } <- e = Just e + | otherwise = Nothing + in + retryOnException isErrorBusy logger oneSecond oneMillisecond maxRetryCount rng action + +makeWithHieDbRetryable :: RandomGen g => Logger -> g -> HieDb -> WithHieDb +makeWithHieDbRetryable logger rng hieDb f = + retryOnSqliteBusy logger rng (f hieDb) + -- | Wraps `withHieDb` to provide a database connection for reading, and a `HieWriterChan` for -- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial -- by a worker thread using a dedicated database connection. -- This is done in order to serialize writes to the database, or else SQLite becomes unhappy -runWithDb :: Logger -> FilePath -> (HieDb -> IndexQueue -> IO ()) -> IO () +runWithDb :: Logger -> FilePath -> (WithHieDb -> IndexQueue -> IO ()) -> IO () runWithDb logger fp k = do + -- use non-deterministic seed because maybe multiple HLS start at same time + -- and send bursts of requests + rng <- Random.newStdGen -- Delete the database if it has an incompatible schema version - withHieDb fp (const $ pure ()) - `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp + retryOnSqliteBusy + logger + rng + (withHieDb fp (const $ pure ()) `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp) + withHieDb fp $ \writedb -> do - initConn writedb + -- the type signature is necessary to avoid concretizing the tyvar + -- e.g. `withWriteDbRetrable initConn` without type signature will + -- instantiate tyvar `a` to `()` + let withWriteDbRetryable :: WithHieDb + withWriteDbRetryable = makeWithHieDbRetryable logger rng writedb + withWriteDbRetryable initConn + chan <- newTQueueIO - withAsync (writerThread writedb chan) $ \_ -> do - withHieDb fp (flip k chan) + + withAsync (writerThread withWriteDbRetryable chan) $ \_ -> do + withHieDb fp (\readDb -> k (makeWithHieDbRetryable logger rng readDb) chan) where - writerThread db chan = do + writerThread :: WithHieDb -> IndexQueue -> IO () + writerThread withHieDbRetryable chan = do -- Clear the index of any files that might have been deleted since the last run - deleteMissingRealFiles db - _ <- garbageCollectTypeNames db + _ <- withHieDbRetryable deleteMissingRealFiles + _ <- withHieDbRetryable garbageCollectTypeNames forever $ do k <- atomically $ readTQueue chan - k db + k withHieDbRetryable `Safe.catch` \e@SQLError{} -> do logDebug logger $ T.pack $ "SQLite error in worker, ignoring: " ++ show e `Safe.catchAny` \e -> do @@ -245,9 +342,10 @@ return $ do extras@ShakeExtras{logger, restartShakeSession, ideNc, knownTargetsVar, lspEnv } <- getShakeExtras - let invalidateShakeCache = do + let invalidateShakeCache :: IO () + invalidateShakeCache = do void $ modifyVar' version succ - recordDirtyKeys extras GhcSessionIO [emptyFilePath] + join $ atomically $ recordDirtyKeys extras GhcSessionIO [emptyFilePath] IdeOptions{ optTesting = IdeTesting optTesting , optCheckProject = getCheckProject @@ -264,13 +362,17 @@ TargetModule _ -> do found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations return (targetTarget, found) - recordDirtyKeys extras GetKnownTargets [emptyFilePath] - modifyVarIO' knownTargetsVar $ traverseHashed $ \known -> do - let known' = HM.unionWith (<>) known $ HM.fromList $ map (second Set.fromList) knownTargets - when (known /= known') $ + hasUpdate <- join $ atomically $ do + known <- readTVar knownTargetsVar + let known' = flip mapHashed known $ \k -> + HM.unionWith (<>) k $ HM.fromList $ map (second Set.fromList) knownTargets + hasUpdate = if known /= known' then Just (unhashed known') else Nothing + writeTVar knownTargetsVar known' + logDirtyKeys <- recordDirtyKeys extras GetKnownTargets [emptyFilePath] + return (logDirtyKeys >> pure hasUpdate) + for_ hasUpdate $ \x -> logDebug logger $ "Known files updated: " <> - T.pack(show $ (HM.map . Set.map) fromNormalizedFilePath known') - pure known' + T.pack(show $ (HM.map . Set.map) fromNormalizedFilePath x) -- Create a new HscEnv from a hieYaml root and a set of options -- If the hieYaml file already has an HscEnv, the new component is @@ -330,7 +432,7 @@ newHscEnv <- -- Add the options for the current component to the HscEnv evalGhcEnv hscEnv $ do - _ <- setSessionDynFlags df + _ <- setSessionDynFlags $ setHomeUnitId_ fakeUid df getSession -- Modify the map so the hieYaml now maps to the newly created @@ -404,7 +506,7 @@ -- update exports map extras <- getShakeExtras let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces - liftIO $ modifyVar_ (exportsMap extras) $ evaluate . (exportsMap' <>) + liftIO $ atomically $ modifyTVar' (exportsMap extras) (exportsMap' <>) return (second Map.keys res) @@ -461,8 +563,8 @@ let sessionOpts :: (Maybe FilePath, FilePath) -> IO (IdeResult HscEnvEq, [FilePath]) sessionOpts (hieYaml, file) = do - v <- fromMaybe HM.empty . Map.lookup hieYaml <$> readVar fileToFlags - cfp <- canonicalizePath file + v <- Map.findWithDefault HM.empty hieYaml <$> readVar fileToFlags + cfp <- makeAbsolute file case HM.lookup (toNormalizedFilePath' cfp) v of Just (opts, old_di) -> do deps_ok <- checkDependencyInfo old_di @@ -483,7 +585,7 @@ -- before attempting to do so. let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath]) getOptions file = do - ncfp <- toNormalizedFilePath' <$> canonicalizePath file + ncfp <- toNormalizedFilePath' <$> makeAbsolute file cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap hieYaml <- cradleLoc file sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `Safe.catch` \e -> @@ -526,10 +628,7 @@ emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv emptyHscEnv nc libDir = do env <- runGhc (Just libDir) getSession - when (Compat.ghcVersion < Compat.GHC90) $ - -- This causes ghc9 to crash with the error: - -- Couldn't find a target code interpreter. Try with -fexternal-interpreter - initDynLinker env + initDynLinker env pure $ setNameCache nc (hscSetFlags ((hsc_dflags env){useUnicode = True }) env) data TargetDetails = TargetDetails @@ -553,11 +652,11 @@ , i <- is , boot <- ["", "-boot"] ] - locs <- mapM (fmap toNormalizedFilePath' . canonicalizePath) fps + locs <- mapM (fmap toNormalizedFilePath' . makeAbsolute) fps return [TargetDetails (TargetModule mod) env dep locs] -- For a 'TargetFile' we consider all the possible module names fromTargetId _ _ (GHC.TargetFile f _) env deps = do - nf <- toNormalizedFilePath' <$> canonicalizePath f + nf <- toNormalizedFilePath' <$> makeAbsolute f return [TargetDetails (TargetFile nf) env deps [nf]] toFlagsMap :: TargetDetails -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))] diff --git a/src/Control/Concurrent/Strict.hs b/src/Control/Concurrent/Strict.hs --- a/src/Control/Concurrent/Strict.hs +++ b/src/Control/Concurrent/Strict.hs @@ -4,25 +4,26 @@ ,module Control.Concurrent.Extra ) where -import Control.Concurrent.Extra hiding (modifyVar, modifyVar_) +import Control.Concurrent.Extra hiding (modifyVar, modifyVar', + modifyVar_) import qualified Control.Concurrent.Extra as Extra import Control.Exception (evaluate) import Control.Monad (void) import Data.Tuple.Extra (dupe) -- | Strict modification that returns the new value -modifyVar' :: Var a -> (a -> a) -> IO a +modifyVar' :: Extra.Var a -> (a -> a) -> IO a modifyVar' var upd = modifyVarIO' var (pure . upd) -- | Strict modification that returns the new value -modifyVarIO' :: Var a -> (a -> IO a) -> IO a +modifyVarIO' :: Extra.Var a -> (a -> IO a) -> IO a modifyVarIO' var upd = do res <- Extra.modifyVar var $ \v -> do v' <- upd v pure $ dupe v' evaluate res -modifyVar :: Var a -> (a -> IO (a, b)) -> IO b +modifyVar :: Extra.Var a -> (a -> IO (a, b)) -> IO b modifyVar var upd = do (new, res) <- Extra.modifyVar var $ \old -> do (new,res) <- upd old @@ -30,5 +31,5 @@ void $ evaluate new return res -modifyVar_ :: Var a -> (a -> IO a) -> IO () +modifyVar_ :: Extra.Var a -> (a -> IO a) -> IO () modifyVar_ var upd = void $ modifyVarIO' var upd diff --git a/src/Development/IDE/Core/Actions.hs b/src/Development/IDE/Core/Actions.hs --- a/src/Development/IDE/Core/Actions.hs +++ b/src/Development/IDE/Core/Actions.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE NoApplicativeDo #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} module Development.IDE.Core.Actions ( getAtPoint , getDefinition @@ -84,24 +84,20 @@ -- | Goto Definition. getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) getDefinition file pos = runMaybeT $ do - ide <- ask + ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask opts <- liftIO $ getIdeOptionsIO ide (HAR _ hf _ _ _, mapping) <- useE GetHieAst file (ImportMap imports, _) <- useE GetImportMap file !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos) - hiedb <- lift $ asks hiedb - dbWriter <- lift $ asks hiedbWriter - toCurrentLocations mapping <$> AtPoint.gotoDefinition hiedb (lookupMod dbWriter) opts imports hf pos' + toCurrentLocations mapping <$> AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos' getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) getTypeDefinition file pos = runMaybeT $ do - ide <- ask + ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask opts <- liftIO $ getIdeOptionsIO ide (hf, mapping) <- useE GetHieAst file !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - hiedb <- lift $ asks hiedb - dbWriter <- lift $ asks hiedbWriter - toCurrentLocations mapping <$> AtPoint.gotoTypeDefinition hiedb (lookupMod dbWriter) opts hf pos' + toCurrentLocations mapping <$> AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos' highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight]) highlightAtPoint file pos = runMaybeT $ do @@ -113,13 +109,13 @@ -- Refs are not an IDE action, so it is OK to be slow and (more) accurate refsAtPoint :: NormalizedFilePath -> Position -> Action [Location] refsAtPoint file pos = do - ShakeExtras{hiedb} <- getShakeExtras + ShakeExtras{withHieDb} <- getShakeExtras fs <- HM.keys <$> getFilesOfInterestUntracked asts <- HM.fromList . mapMaybe sequence . zip fs <$> usesWithStale GetHieAst fs - AtPoint.referencesAtPoint hiedb file pos (AtPoint.FOIReferences asts) + AtPoint.referencesAtPoint withHieDb file pos (AtPoint.FOIReferences asts) workspaceSymbols :: T.Text -> IdeAction (Maybe [SymbolInformation]) workspaceSymbols query = runMaybeT $ do - hiedb <- lift $ asks hiedb - res <- liftIO $ HieDb.searchDef hiedb $ T.unpack query + ShakeExtras{withHieDb} <- ask + res <- liftIO $ withHieDb (\hieDb -> HieDb.searchDef hieDb $ T.unpack query) pure $ mapMaybe AtPoint.defRowToSymbolInfo res diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -27,7 +27,6 @@ , loadHieFile , loadInterface , loadModulesHome - , setupFinderCache , getDocsBatch , lookupName ,mergeEnvs) where @@ -56,9 +55,9 @@ import Language.LSP.Types (DiagnosticTag (..)) #if MIN_VERSION_ghc(8,10,0) -import Control.DeepSeq (force, rnf) +import Control.DeepSeq (force, liftRnf, rnf, rwhnf) #else -import Control.DeepSeq (rnf) +import Control.DeepSeq (liftRnf, rnf, rwhnf) import ErrUtils #endif @@ -69,6 +68,10 @@ import TcSplice #endif +#if MIN_VERSION_ghc(9,2,0) +import qualified GHC.Types.Error as Error +#endif + import Control.Exception (evaluate) import Control.Exception.Safe import Control.Lens hiding (List) @@ -79,6 +82,7 @@ import qualified Data.ByteString as BS import qualified Data.DList as DL import Data.IORef +import qualified Data.IntMap.Strict as IntMap import Data.List.Extra import qualified Data.Map.Strict as Map import Data.Maybe @@ -96,12 +100,13 @@ parsedSource) import Control.Concurrent.Extra -import Control.Concurrent.STM hiding (orElse) +import Control.Concurrent.STM.Stats hiding (orElse) import Data.Aeson (toJSON) import Data.Binary import Data.Coerce import Data.Functor import qualified Data.HashMap.Strict as HashMap +import Data.IntMap (IntMap) import Data.Map (Map) import Data.Tuple.Extra (dupe) import Data.Unique as Unique @@ -142,24 +147,27 @@ -> ParsedModule -> IO (IdeResult TcModuleResult) typecheckModule (IdeDefer defer) hsc keep_lbls pm = do - fmap (either (,Nothing) id) $ - catchSrcErrors (hsc_dflags hsc) "typecheck" $ do - let modSummary = pm_mod_summary pm dflags = ms_hspp_opts modSummary - - modSummary' <- initPlugins hsc modSummary - (warnings, tcm) <- withWarnings "typecheck" $ \tweak -> - let - session = tweak (hscSetFlags dflags hsc) - -- TODO: maybe settings ms_hspp_opts is unnecessary? - mod_summary'' = modSummary' { ms_hspp_opts = hsc_dflags session} - in - tcRnModule hsc keep_lbls $ demoteIfDefer pm{pm_mod_summary = mod_summary''} - let errorPipeline = unDefer . hideDiag dflags . tagDiag - diags = map errorPipeline warnings - deferedError = any fst diags - return (map snd diags, Just $ tcm{tmrDeferedError = deferedError}) + mmodSummary' <- catchSrcErrors (hsc_dflags hsc) "typecheck (initialize plugins)" + (initPlugins hsc modSummary) + case mmodSummary' of + Left errs -> return (errs, Nothing) + Right modSummary' -> do + (warnings, etcm) <- withWarnings "typecheck" $ \tweak -> + let + session = tweak (hscSetFlags dflags hsc) + -- TODO: maybe settings ms_hspp_opts is unnecessary? + mod_summary'' = modSummary' { ms_hspp_opts = hsc_dflags session} + in + catchSrcErrors (hsc_dflags hsc) "typecheck" $ do + tcRnModule session keep_lbls $ demoteIfDefer pm{pm_mod_summary = mod_summary''} + let errorPipeline = unDefer . hideDiag dflags . tagDiag + diags = map errorPipeline warnings + deferedError = any fst diags + case etcm of + Left errs -> return (map snd diags ++ errs, Nothing) + Right tcm -> return (map snd diags, Just $ tcm{tmrDeferedError = deferedError}) where demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id @@ -208,7 +216,7 @@ unload hsc_env_tmp keep_lbls ((tc_gbl_env, mrn_info), splices) - <- liftIO $ captureSplices (hscSetFlags (ms_hspp_opts ms) hsc_env) $ \hsc_env_tmp -> + <- liftIO $ captureSplices hsc_env_tmp $ \hsc_env_tmp -> do hscTypecheckRename hsc_env_tmp ms $ HsParsedModule { hpm_module = parsedSource pmod, hpm_src_files = pm_extra_src_files pmod, @@ -305,6 +313,8 @@ (warnings,desugared_guts) <- withWarnings "compile" $ \tweak -> do let session' = tweak (hscSetFlags (ms_hspp_opts ms) session) -- TODO: maybe settings ms_hspp_opts is unnecessary? + -- MP: the flags in ModSummary should be right, if they are wrong then + -- the correct place to fix this is when the ModSummary is created. desugar <- hscDesugar session' (ms { ms_hspp_opts = hsc_dflags session' }) tcg if simplify then do @@ -325,7 +335,7 @@ withWarnings "object" $ \tweak -> do let env' = tweak (hscSetFlags (ms_hspp_opts summary) session) target = platformDefaultBackend (hsc_dflags env') - newFlags = setBackend target $ updOptLevel 0 $ (hsc_dflags env') { outputFile = Just dot_o } + newFlags = setBackend target $ updOptLevel 0 $ setOutputFile dot_o $ hsc_dflags env' session' = hscSetFlags newFlags session #if MIN_VERSION_ghc(9,0,1) (outputFilename, _mStub, _foreign_files, _cinfos) <- hscGenHardCode session' guts @@ -465,12 +475,19 @@ top_ev_binds = tcg_ev_binds ts :: Util.Bag EvBind insts = tcg_insts ts :: [ClsInst] tcs = tcg_tcs ts :: [TyCon] - Just <$> GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs + run ts $ + Just <$> GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs #else Just <$> GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) #endif where dflags = hsc_dflags hscEnv + run ts = +#if MIN_VERSION_ghc(9,2,0) + fmap (join . snd) . liftIO . initDs hscEnv ts +#else + id +#endif spliceExpresions :: Splices -> [LHsExpr GhcTc] spliceExpresions Splices{..} = @@ -521,7 +538,7 @@ -- hiedb doesn't use the Haskell src, so we clear it to avoid unnecessarily keeping it around let !hf' = hf{hie_hs_src = mempty} modifyTVar' indexPending $ HashMap.insert srcPath hash - writeTQueue indexQueue $ \db -> do + writeTQueue indexQueue $ \withHieDb -> do -- We are now in the worker thread -- Check if a newer index of this file has been scheduled, and if so skip this one newerScheduled <- atomically $ do @@ -532,7 +549,7 @@ Just pendingHash -> pendingHash /= hash unless newerScheduled $ do pre optProgressStyle - addRefsFromLoaded db targetPath (RealFile $ fromNormalizedFilePath srcPath) hash hf' + withHieDb (\db -> HieDb.addRefsFromLoaded db targetPath (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf') post where mod_location = ms_location mod_summary @@ -564,6 +581,11 @@ done <- readTVar indexCompleted remaining <- HashMap.size <$> readTVar indexPending pure (done, remaining) + let + progressFrac :: Double + progressFrac = fromIntegral done / fromIntegral (done + remaining) + progressPct :: LSP.UInt + progressPct = floor $ 100 * progressFrac whenJust (lspEnv se) $ \env -> whenJust tok $ \tok -> LSP.runLspT env $ LSP.sendNotification LSP.SProgress $ LSP.ProgressParams tok $ @@ -572,7 +594,7 @@ Percentage -> LSP.WorkDoneProgressReportParams { _cancellable = Nothing , _message = Nothing - , _percentage = Just (100 * fromIntegral done / fromIntegral (done + remaining) ) + , _percentage = Just progressPct } Explicit -> LSP.WorkDoneProgressReportParams { _cancellable = Nothing @@ -650,30 +672,6 @@ . (("Error during " ++ T.unpack source) ++) . show @SomeException ] --- | Initialise the finder cache, dependencies should be topologically --- sorted. -setupFinderCache :: [ModSummary] -> HscEnv -> IO HscEnv -setupFinderCache mss session = do - - -- Make modules available for others that import them, - -- by putting them in the finder cache. - let ims = map (installedModule (homeUnitId_ $ hsc_dflags session) . moduleName . ms_mod) mss - ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims - -- set the target and module graph in the session - graph = mkModuleGraph mss - - -- We have to create a new IORef here instead of modifying the existing IORef as - -- it is shared between concurrent compilations. - prevFinderCache <- readIORef $ hsc_FC session - let newFinderCache = - foldl' - (\fc (im, ifr) -> GHC.extendInstalledModuleEnv fc im ifr) prevFinderCache - $ zip ims ifrs - newFinderCacheVar <- newIORef $! newFinderCache - - pure $ session { hsc_FC = newFinderCacheVar, hsc_mod_graph = graph } - - -- | Load modules, quickly. Input doesn't need to be desugared. -- A module must be loaded before dependent modules can be typechecked. -- This variant of loadModuleHome will *never* cause recompilation, it just @@ -686,7 +684,8 @@ -> HscEnv -> HscEnv loadModulesHome mod_infos e = - e { hsc_HPT = addListToHpt (hsc_HPT e) [(mod_name x, x) | x <- mod_infos] + let !new_modules = addListToHpt (hsc_HPT e) [(mod_name x, x) | x <- mod_infos] + in e { hsc_HPT = new_modules , hsc_type_env_var = Nothing } where mod_name = moduleName . mi_module . hm_iface @@ -695,17 +694,29 @@ mergeEnvs :: HscEnv -> [ModSummary] -> [HomeModInfo] -> [HscEnv] -> IO HscEnv mergeEnvs env extraModSummaries extraMods envs = do prevFinderCache <- concatFC <$> mapM (readIORef . hsc_FC) envs - let ims = map (Compat.installedModule (homeUnitId_ $ hsc_dflags env) . moduleName . ms_mod) extraModSummaries + let ims = map (\ms -> Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))) extraModSummaries ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) extraModSummaries ims + -- Very important to force this as otherwise the hsc_mod_graph field is not + -- forced and ends up retaining a reference to all the old hsc_envs we have merged to get + -- this new one, which in turn leads to the EPS referencing the HPT. + module_graph_nodes = +#if MIN_VERSION_ghc(9,2,0) + -- 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. + map extendModSummaryNoDeps $ +#endif + extraModSummaries ++ nubOrdOn ms_mod (concatMap (mgModSummaries . hsc_mod_graph) envs) + newFinderCache <- newIORef $ foldl' (\fc (im, ifr) -> Compat.extendInstalledModuleEnv fc im ifr) prevFinderCache $ zip ims ifrs - return $ loadModulesHome extraMods $ env{ + liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $ env{ hsc_HPT = foldMapBy mergeUDFM emptyUDFM hsc_HPT envs, hsc_FC = newFinderCache, - hsc_mod_graph = mkModuleGraph $ extraModSummaries ++ nubOrdOn ms_mod (concatMap (mgModSummaries . hsc_mod_graph) envs) - } + hsc_mod_graph = mkModuleGraph module_graph_nodes + }) where mergeUDFM = plusUDFM_C combineModules combineModules a b @@ -753,8 +764,9 @@ implicit_prelude = xopt LangExt.ImplicitPrelude dflags implicit_imports = mkPrelImports mod main_loc implicit_prelude imps + convImport (L _ i) = (fmap sl_fs (ideclPkgQual i) - , ideclName i) + , reLoc $ ideclName i) srcImports = map convImport src_idecls textualImports = map convImport (implicit_imports ++ ordinary_imps) @@ -824,15 +836,11 @@ parseHeader dflags filename contents = do let loc = mkRealSrcLoc (Util.mkFastString filename) 1 1 case unP Compat.parseHeader (initParserState (initParserOpts dflags) contents loc) of -#if MIN_VERSION_ghc(8,10,0) - PFailed pst -> - throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags -#else - PFailed _ locErr msgErr -> - throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr -#endif + PFailedWithErrorMessages msgs -> + throwE $ diagFromErrMsgs "parser" dflags $ msgs dflags POk pst rdr_module -> do - let (warns, errs) = getMessages pst dflags + let (warns, errs) = getMessages' pst dflags + -- Just because we got a `POk`, it doesn't mean there -- weren't errors! To clarify, the GHC parser -- distinguishes between fatal and non-fatal @@ -843,9 +851,9 @@ -- errors are those from which a parse tree just can't -- be produced. unless (null errs) $ - throwE $ diagFromErrMsgs "parser" dflags (fmap pprError errs) + throwE $ diagFromErrMsgs "parser" dflags errs - let warnings = diagFromErrMsgs "parser" dflags (fmap pprWarning warns) + let warnings = diagFromErrMsgs "parser" dflags warns return (warnings, rdr_module) -- | Given a buffer, flags, and file path, produce a @@ -862,16 +870,11 @@ dflags = ms_hspp_opts ms contents = fromJust $ ms_hspp_buf ms case unP Compat.parseModule (initParserState (initParserOpts dflags) contents loc) of -#if MIN_VERSION_ghc(8,10,0) - PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags -#else - PFailed _ locErr msgErr -> - throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr -#endif + PFailedWithErrorMessages msgs -> throwE $ diagFromErrMsgs "parser" dflags $ msgs dflags POk pst rdr_module -> let hpm_annotations = mkApiAnns pst - (warns, errs) = getMessages pst dflags + (warns, errs) = getMessages' pst dflags in do -- Just because we got a `POk`, it doesn't mean there @@ -921,7 +924,7 @@ -- filter them out: srcs2 <- liftIO $ filterM doesFileExist srcs1 - let pm = mkParsedModule ms parsed' srcs2 hpm_annotations + let pm = ParsedModule ms parsed' srcs2 hpm_annotations warnings = diagFromErrMsgs "parser" dflags warns pure (warnings ++ preproc_warnings, pm) @@ -998,9 +1001,9 @@ :: HscEnv -> Module -- ^ a moudle where the names are in scope -> [Name] - -> IO [Either String (Maybe HsDocString, Map.Map Int HsDocString)] + -> IO [Either String (Maybe HsDocString, IntMap HsDocString)] getDocsBatch hsc_env _mod _names = do - ((_warns,errs), res) <- initTc hsc_env HsSrcFile False _mod fakeSpan $ forM _names $ \name -> + (msgs, res) <- initTc hsc_env HsSrcFile False _mod fakeSpan $ forM _names $ \name -> case nameModule_maybe name of Nothing -> return (Left $ NameHasNoModule name) Just mod -> do @@ -1008,13 +1011,21 @@ , mi_decl_docs = DeclDocMap dmap , mi_arg_docs = ArgDocMap amap } <- loadModuleInterface "getModuleInterface" mod - if isNothing mb_doc_hdr && Map.null dmap && Map.null amap + if isNothing mb_doc_hdr && Map.null dmap && null amap then pure (Left (NoDocsInIface mod $ compiled name)) - else pure (Right ( Map.lookup name dmap - , Map.findWithDefault Map.empty name amap)) + else pure (Right ( Map.lookup name dmap , +#if !MIN_VERSION_ghc(9,2,0) + IntMap.fromAscList $ Map.toAscList $ +#endif + Map.findWithDefault mempty name amap)) case res of Just x -> return $ map (first $ T.unpack . showGhc) x - Nothing -> throwErrors errs + Nothing -> throwErrors +#if MIN_VERSION_ghc(9,2,0) + $ Error.getErrorMessages msgs +#else + $ snd msgs +#endif where throwErrors = liftIO . throwIO . mkSrcErr compiled n = diff --git a/src/Development/IDE/Core/Debouncer.hs b/src/Development/IDE/Core/Debouncer.hs --- a/src/Development/IDE/Core/Debouncer.hs +++ b/src/Development/IDE/Core/Debouncer.hs @@ -9,13 +9,13 @@ ) where import Control.Concurrent.Async -import Control.Concurrent.Strict +import Control.Concurrent.STM.Stats (atomically, atomicallyNamed) import Control.Exception -import Control.Monad (join) -import Data.Foldable (traverse_) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as Map +import Control.Monad (join) +import Data.Foldable (traverse_) import Data.Hashable +import qualified Focus +import qualified StmContainers.Map as STM import System.Time.Extra -- | A debouncer can be used to avoid triggering many events @@ -31,7 +31,7 @@ -- | Debouncer used in the IDE that delays events as expected. newAsyncDebouncer :: (Eq k, Hashable k) => IO (Debouncer k) -newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> newVar Map.empty +newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> STM.newIO -- | Register an event that will fire after the given delay if no other event -- for the same key gets registered until then. @@ -39,20 +39,20 @@ -- If there is a pending event for the same key, the pending event will be killed. -- Events are run unmasked so it is up to the user of `registerEvent` -- to mask if required. -asyncRegisterEvent :: (Eq k, Hashable k) => Var (HashMap k (Async ())) -> Seconds -> k -> IO () -> IO () +asyncRegisterEvent :: (Eq k, Hashable k) => STM.Map k (Async ()) -> Seconds -> k -> IO () -> IO () asyncRegisterEvent d 0 k fire = do - join $ modifyVar d $ \m -> do - (cancel, !m') <- evaluate $ Map.alterF (\prev -> (traverse_ cancel prev, Nothing)) k m - return (m', cancel) + join $ atomically $ do + prev <- STM.focus Focus.lookupAndDelete k d + return $ traverse_ cancel prev fire asyncRegisterEvent d delay k fire = mask_ $ do a <- asyncWithUnmask $ \unmask -> unmask $ do sleep delay fire - modifyVar_ d (evaluate . Map.delete k) - join $ modifyVar d $ \m -> do - (cancel, !m') <- evaluate $ Map.alterF (\prev -> (traverse_ cancel prev, Just a)) k m - return (m', cancel) + atomically $ STM.delete k d + do + prev <- atomicallyNamed "debouncer" $ STM.focus (Focus.lookup <* Focus.insert a) k d + traverse_ cancel prev -- | Debouncer used in the DAML CLI compiler that emits events immediately. noopDebouncer :: Debouncer k diff --git a/src/Development/IDE/Core/FileExists.hs b/src/Development/IDE/Core/FileExists.hs --- a/src/Development/IDE/Core/FileExists.hs +++ b/src/Development/IDE/Core/FileExists.hs @@ -10,13 +10,12 @@ ) where -import Control.Concurrent.Strict +import Control.Concurrent.STM.Stats (atomically, + atomicallyNamed) import Control.Exception import Control.Monad.Extra import Control.Monad.IO.Class import qualified Data.ByteString as BS -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap import Data.List (partition) import Data.Maybe import Development.IDE.Core.FileStore @@ -26,9 +25,11 @@ import Development.IDE.Graph import Development.IDE.Types.Location import Development.IDE.Types.Options +import qualified Focus import Ide.Plugin.Config (Config) import Language.LSP.Server hiding (getVirtualFile) import Language.LSP.Types +import qualified StmContainers.Map as STM import qualified System.Directory as Dir import qualified System.FilePath.Glob as Glob @@ -74,10 +75,10 @@ -- | A map for tracking the file existence. -- If a path maps to 'True' then it exists; if it maps to 'False' then it doesn't exist'; and -- if it's not in the map then we don't know. -type FileExistsMap = (HashMap NormalizedFilePath Bool) +type FileExistsMap = STM.Map NormalizedFilePath Bool -- | A wrapper around a mutable 'FileExistsState' -newtype FileExistsMapVar = FileExistsMapVar (Var FileExistsMap) +newtype FileExistsMapVar = FileExistsMapVar FileExistsMap instance IsIdeGlobal FileExistsMapVar @@ -85,24 +86,27 @@ getFileExistsMapUntracked :: Action FileExistsMap getFileExistsMapUntracked = do FileExistsMapVar v <- getIdeGlobalAction - liftIO $ readVar v + return v -- | Modify the global store of file exists. modifyFileExists :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO () modifyFileExists state changes = do FileExistsMapVar var <- getIdeGlobalState state - changesMap <- evaluate $ HashMap.fromList changes -- Masked to ensure that the previous values are flushed together with the map update - mask $ \_ -> do -- update the map - void $ modifyVar' var $ HashMap.union (HashMap.mapMaybe fromChange changesMap) + mask_ $ join $ atomicallyNamed "modifyFileExists" $ do + forM_ changes $ \(f,c) -> + case fromChange c of + Just c' -> STM.focus (Focus.insert c') f var + Nothing -> pure () -- See Note [Invalidating file existence results] -- flush previous values let (fileModifChanges, fileExistChanges) = - partition ((== FcChanged) . snd) (HashMap.toList changesMap) + partition ((== FcChanged) . snd) changes mapM_ (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges - recordDirtyKeys (shakeExtras state) GetFileExists $ map fst fileExistChanges - recordDirtyKeys (shakeExtras state) GetModificationTime $ map fst fileModifChanges + io1 <- recordDirtyKeys (shakeExtras state) GetFileExists $ map fst fileExistChanges + io2 <- recordDirtyKeys (shakeExtras state) GetModificationTime $ map fst fileModifChanges + return (io1 <> io2) fromChange :: FileChangeType -> Maybe Bool fromChange FcCreated = Just True @@ -161,7 +165,7 @@ -- Create the global always, although it should only be used if we have fast rules. -- But there's a chance someone will send unexpected notifications anyway, -- e.g. https://github.com/haskell/ghcide/issues/599 - addIdeGlobal . FileExistsMapVar =<< liftIO (newVar []) + addIdeGlobal . FileExistsMapVar =<< liftIO STM.newIO extras <- getShakeExtrasRules opts <- liftIO $ getIdeOptionsIO extras @@ -210,7 +214,7 @@ -- Could in principle use 'alwaysRerun' here, but it's too slwo, See Note [Invalidating file existence results] mp <- getFileExistsMapUntracked - let mbFilesWatched = HashMap.lookup file mp + mbFilesWatched <- liftIO $ atomically $ STM.lookup file mp exist <- case mbFilesWatched of Just exist -> pure exist -- We don't know about it: use the slow route. diff --git a/src/Development/IDE/Core/FileStore.hs b/src/Development/IDE/Core/FileStore.hs --- a/src/Development/IDE/Core/FileStore.hs +++ b/src/Development/IDE/Core/FileStore.hs @@ -24,7 +24,8 @@ registerFileWatches ) where -import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.Stats (STM, atomically, + modifyTVar') import Control.Concurrent.STM.TQueue (writeTQueue) import Control.Concurrent.Strict import Control.Exception @@ -63,7 +64,6 @@ import qualified Data.Binary as B import qualified Data.ByteString.Lazy as LBS import qualified Data.HashSet as HSet -import Data.IORef.Extra (atomicModifyIORef_) import Data.List (foldl') import qualified Data.Text as Text import Development.IDE.Core.IdeConfiguration (isWorkspaceFile) @@ -160,7 +160,7 @@ isInterface f = takeExtension (fromNormalizedFilePath f) `elem` [".hi", ".hi-boot"] -- | Reset the GetModificationTime state of interface files -resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> IO () +resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM () resetInterfaceStore state f = do deleteValue state GetModificationTime f @@ -175,7 +175,8 @@ case c of FcChanged -- already checked elsewhere | not $ HM.member nfp fois - -> deleteValue (shakeExtras ideState) GetModificationTime nfp + -> atomically $ + deleteValue (shakeExtras ideState) GetModificationTime nfp _ -> pure () @@ -262,7 +263,7 @@ VFSHandle{..} <- getIdeGlobalState state when (isJust setVirtualFileContents) $ fail "setFileModified can't be called on this type of VFSHandle" - recordDirtyKeys (shakeExtras state) GetModificationTime [nfp] + join $ atomically $ recordDirtyKeys (shakeExtras state) GetModificationTime [nfp] restartShakeSession (shakeExtras state) (fromNormalizedFilePath nfp ++ " (modified)") [] when checkParents $ typecheckParents state nfp @@ -292,9 +293,10 @@ when (isJust setVirtualFileContents) $ fail "setSomethingModified can't be called on this type of VFSHandle" -- Update database to remove any files that might have been renamed/deleted - atomically $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) deleteMissingRealFiles - atomicModifyIORef_ (dirtyKeys $ shakeExtras state) $ \x -> - foldl' (flip HSet.insert) x keys + atomically $ do + writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) + modifyTVar' (dirtyKeys $ shakeExtras state) $ \x -> + foldl' (flip HSet.insert) x keys void $ restartShakeSession (shakeExtras state) reason [] registerFileWatches :: [String] -> LSP.LspT Config IO Bool diff --git a/src/Development/IDE/Core/OfInterest.hs b/src/Development/IDE/Core/OfInterest.hs --- a/src/Development/IDE/Core/OfInterest.hs +++ b/src/Development/IDE/Core/OfInterest.hs @@ -20,19 +20,26 @@ import Control.Concurrent.Strict import Control.Monad import Control.Monad.IO.Class -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Text as T +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Text as T import Development.IDE.Graph -import qualified Data.ByteString as BS -import Data.Maybe (catMaybes) +import Control.Concurrent.STM.Stats (atomically, + modifyTVar') +import Data.Aeson (toJSON) +import qualified Data.ByteString as BS +import Data.Maybe (catMaybes) import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake +import Development.IDE.Plugin.Completions.Types import Development.IDE.Types.Exports import Development.IDE.Types.Location import Development.IDE.Types.Logger +import Development.IDE.Types.Options (IdeTesting (..)) +import qualified Language.LSP.Server as LSP +import qualified Language.LSP.Types as LSP newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) instance IsIdeGlobal OfInterestVar @@ -86,7 +93,7 @@ let (prev, new) = HashMap.alterF (, Just v) f dict pure (new, (prev, new)) when (prev /= Just v) $ - recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] + join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show files) @@ -94,7 +101,7 @@ deleteFileOfInterest state f = do OfInterestVar var <- getIdeGlobalState state files <- modifyVar' var $ HashMap.delete f - recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] + join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show files) scheduleGarbageCollection :: IdeState -> IO () @@ -107,13 +114,23 @@ kick :: Action () kick = do files <- HashMap.keys <$> getFilesOfInterestUntracked - ShakeExtras{exportsMap, progress} <- getShakeExtras + ShakeExtras{exportsMap, ideTesting = IdeTesting testing, lspEnv, progress} <- getShakeExtras + let signal msg = when testing $ liftIO $ + mRunLspT lspEnv $ + LSP.sendNotification (LSP.SCustomMethod msg) $ + toJSON $ map fromNormalizedFilePath files + + signal "kick/start" liftIO $ progressUpdate progress KickStarted -- Update the exports map - results <- uses GenerateCore files <* uses GetHieAst files + results <- uses GenerateCore files + <* uses GetHieAst files + -- needed to have non local completions on the first edit + -- when the first edit breaks the module header + <* uses NonLocalCompletions files let mguts = catMaybes results - void $ liftIO $ modifyVar' exportsMap (updateExportsMapMg mguts) + void $ liftIO $ atomically $ modifyTVar' exportsMap (updateExportsMapMg mguts) liftIO $ progressUpdate progress KickCompleted @@ -122,3 +139,5 @@ when garbageCollectionScheduled $ do void garbageCollectDirtyKeys liftIO $ writeVar var False + + signal "kick/done" diff --git a/src/Development/IDE/Core/PositionMapping.hs b/src/Development/IDE/Core/PositionMapping.hs --- a/src/Development/IDE/Core/PositionMapping.hs +++ b/src/Development/IDE/Core/PositionMapping.hs @@ -31,7 +31,8 @@ import qualified Data.Text as T import qualified Data.Vector.Unboxed as V import Language.LSP.Types (Position (Position), Range (Range), - TextDocumentContentChangeEvent (TextDocumentContentChangeEvent)) + TextDocumentContentChangeEvent (TextDocumentContentChangeEvent), + UInt) -- | Either an exact position, or the range of text that was substituted data PositionResult a @@ -140,14 +141,17 @@ where lineDiff = linesNew - linesOld linesNew = T.count "\n" t - linesOld = endLine - startLine + linesOld = fromIntegral endLine - fromIntegral startLine + newEndColumn :: UInt newEndColumn - | linesNew == 0 = startColumn + T.length t - | otherwise = T.length $ T.takeWhileEnd (/= '\n') t + | linesNew == 0 = fromIntegral $ fromIntegral startColumn + T.length t + | otherwise = fromIntegral $ T.length $ T.takeWhileEnd (/= '\n') t + newColumn :: UInt newColumn - | line == endLine = column + newEndColumn - endColumn + | line == endLine = fromIntegral $ (fromIntegral column + newEndColumn) - fromIntegral endColumn | otherwise = column - newLine = line + lineDiff + newLine :: UInt + newLine = fromIntegral $ fromIntegral line + lineDiff fromCurrent :: Range -> T.Text -> Position -> PositionResult Position fromCurrent (Range start@(Position startLine startColumn) end@(Position endLine endColumn)) t (Position line column) @@ -163,19 +167,23 @@ where lineDiff = linesNew - linesOld linesNew = T.count "\n" t - linesOld = endLine - startLine - newEndLine = endLine + lineDiff + linesOld = fromIntegral endLine - fromIntegral startLine + newEndLine :: UInt + newEndLine = fromIntegral $ fromIntegral endLine + lineDiff + newEndColumn :: UInt newEndColumn - | linesNew == 0 = startColumn + T.length t - | otherwise = T.length $ T.takeWhileEnd (/= '\n') t + | linesNew == 0 = fromIntegral $ fromIntegral startColumn + T.length t + | otherwise = fromIntegral $ T.length $ T.takeWhileEnd (/= '\n') t + newColumn :: UInt newColumn - | line == newEndLine = column - (newEndColumn - endColumn) + | line == newEndLine = fromIntegral $ (fromIntegral column + fromIntegral endColumn) - newEndColumn | otherwise = column - newLine = line - lineDiff + newLine :: UInt + newLine = fromIntegral $ fromIntegral line - lineDiff deltaFromDiff :: T.Text -> T.Text -> PositionDelta deltaFromDiff (T.lines -> old) (T.lines -> new) = - PositionDelta (lookupPos lnew o2nPrevs o2nNexts old2new) (lookupPos lold n2oPrevs n2oNexts new2old) + PositionDelta (lookupPos (fromIntegral lnew) o2nPrevs o2nNexts old2new) (lookupPos (fromIntegral lold) n2oPrevs n2oNexts new2old) where !lnew = length new !lold = length old @@ -194,17 +202,16 @@ f :: Int -> Int -> Int f !a !b = if b == -1 then a else b - lookupPos :: Int -> V.Vector Int -> V.Vector Int -> V.Vector Int -> Position -> PositionResult Position + lookupPos :: UInt -> V.Vector Int -> V.Vector Int -> V.Vector Int -> Position -> PositionResult Position lookupPos end prevs nexts xs (Position line col) - | line < 0 = PositionRange (Position 0 0) (Position 0 0) - | line >= V.length xs = PositionRange (Position end 0) (Position end 0) - | otherwise = case V.unsafeIndex xs line of + | line >= fromIntegral (V.length xs) = PositionRange (Position end 0) (Position end 0) + | otherwise = case V.unsafeIndex xs (fromIntegral line) of -1 -> -- look for the previous and next lines that mapped successfully - let !prev = 1 + V.unsafeIndex prevs line - !next = V.unsafeIndex nexts line - in PositionRange (Position prev 0) (Position next 0) - line' -> PositionExact (Position line' col) + let !prev = 1 + V.unsafeIndex prevs (fromIntegral line) + !next = V.unsafeIndex nexts (fromIntegral line) + in PositionRange (Position (fromIntegral prev) 0) (Position (fromIntegral next) 0) + line' -> PositionExact (Position (fromIntegral line') col) -- Construct a mapping between lines in the diff -- -1 for unsucessful mapping diff --git a/src/Development/IDE/Core/ProgressReporting.hs b/src/Development/IDE/Core/ProgressReporting.hs --- a/src/Development/IDE/Core/ProgressReporting.hs +++ b/src/Development/IDE/Core/ProgressReporting.hs @@ -9,27 +9,31 @@ , mRunLspTCallback -- for tests , recordProgress - , InProgress(..) + , InProgressState(..) ) where import Control.Concurrent.Async +import Control.Concurrent.STM.Stats (TVar, atomicallyNamed, + modifyTVar', newTVarIO, + readTVarIO) import Control.Concurrent.Strict import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) import Data.Foldable (for_) import Data.Functor (($>)) -import qualified Data.HashMap.Strict as HMap import qualified Data.Text as T import Data.Unique import Development.IDE.GHC.Orphans () import Development.IDE.Graph hiding (ShakeValue) import Development.IDE.Types.Location import Development.IDE.Types.Options +import qualified Focus import qualified Language.LSP.Server as LSP import Language.LSP.Types import qualified Language.LSP.Types as LSP +import qualified StmContainers.Map as STM import System.Time.Extra import UnliftIO.Exception (bracket_) @@ -69,26 +73,33 @@ updateState _ StopProgress st = pure st -- | Data structure to track progress across the project -data InProgress = InProgress - { todo :: !Int -- ^ Number of files to do - , done :: !Int -- ^ Number of files done - , current :: !(HMap.HashMap NormalizedFilePath Int) +data InProgressState = InProgressState + { todoVar :: TVar Int -- ^ Number of files to do + , doneVar :: TVar Int -- ^ Number of files done + , currentVar :: STM.Map NormalizedFilePath Int } -recordProgress :: NormalizedFilePath -> (Int -> Int) -> InProgress -> InProgress -recordProgress file shift InProgress{..} = case HMap.alterF alter file current of - ((prev, new), m') -> - let (done',todo') = - case (prev,new) of - (Nothing,0) -> (done+1, todo+1) - (Nothing,_) -> (done, todo+1) - (Just 0, 0) -> (done , todo) - (Just 0, _) -> (done-1, todo) - (Just _, 0) -> (done+1, todo) - (Just _, _) -> (done , todo) - in InProgress todo' done' m' +newInProgress :: IO InProgressState +newInProgress = InProgressState <$> newTVarIO 0 <*> newTVarIO 0 <*> STM.newIO + +recordProgress :: InProgressState -> NormalizedFilePath -> (Int -> Int) -> IO () +recordProgress InProgressState{..} file shift = do + (prev, new) <- atomicallyNamed "recordProgress" $ STM.focus alterPrevAndNew file currentVar + atomicallyNamed "recordProgress2" $ do + case (prev,new) of + (Nothing,0) -> modifyTVar' doneVar (+1) >> modifyTVar' todoVar (+1) + (Nothing,_) -> modifyTVar' todoVar (+1) + (Just 0, 0) -> pure () + (Just 0, _) -> modifyTVar' doneVar pred + (Just _, 0) -> modifyTVar' doneVar (+1) + (Just _, _) -> pure() where - alter x = let x' = maybe (shift 0) shift x in ((x,x'), Just x') + alterPrevAndNew = do + prev <- Focus.lookup + Focus.alter alter + new <- Focus.lookupWithDefault 0 + return (prev, new) + alter x = let x' = maybe (shift 0) shift x in Just x' -- | A 'ProgressReporting' that enqueues Begin and End notifications in a new -- thread, with a grace period (nothing will be sent if 'KickCompleted' arrives @@ -100,17 +111,16 @@ -> ProgressReportingStyle -> IO ProgressReporting delayedProgressReporting before after lspEnv optProgressStyle = do - inProgressVar <- newVar $ InProgress 0 0 mempty + inProgressState <- newInProgress progressState <- newVar NotStarted let progressUpdate event = updateStateVar $ Event event progressStop = updateStateVar StopProgress - updateStateVar = modifyVar_ progressState . updateState (mRunLspT lspEnv $ lspShakeProgress inProgressVar) + updateStateVar = modifyVar_ progressState . updateState (mRunLspT lspEnv $ lspShakeProgress inProgressState) - inProgress :: NormalizedFilePath -> Action a -> Action a - inProgress = withProgressVar inProgressVar + inProgress = updateStateForFile inProgressState return ProgressReporting{..} where - lspShakeProgress inProgress = do + lspShakeProgress InProgressState{..} = do -- first sleep a bit, so we only show progress messages if it's going to take -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes) liftIO $ sleep before @@ -142,12 +152,17 @@ } loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound - loop id prev = do - InProgress{..} <- liftIO $ readVar inProgress + loop id prevPct = do + done <- liftIO $ readTVarIO doneVar + todo <- liftIO $ readTVarIO todoVar liftIO $ sleep after if todo == 0 then loop id 0 else do - let next = 100 * fromIntegral done / fromIntegral todo - when (next /= prev) $ + let + nextFrac :: Double + nextFrac = fromIntegral done / fromIntegral todo + nextPct :: UInt + nextPct = floor $ 100 * nextFrac + when (nextPct /= prevPct) $ LSP.sendNotification LSP.SProgress $ LSP.ProgressParams { _token = id @@ -160,18 +175,18 @@ Percentage -> LSP.WorkDoneProgressReportParams { _cancellable = Nothing , _message = Nothing - , _percentage = Just next + , _percentage = Just nextPct } NoProgress -> error "unreachable" } - loop id next + loop id nextPct - withProgressVar var file = actionBracket (f succ) (const $ f pred) . const + updateStateForFile inProgress file = actionBracket (f succ) (const $ f pred) . const -- This functions are deliberately eta-expanded to avoid space leaks. -- Do not remove the eta-expansion without profiling a session with at -- least 1000 modifications. where - f shift = modifyVar' var $ recordProgress file shift + f shift = recordProgress inProgress file shift mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m () mRunLspT (Just lspEnv) f = LSP.runLspT lspEnv f diff --git a/src/Development/IDE/Core/RuleTypes.hs b/src/Development/IDE/Core/RuleTypes.hs --- a/src/Development/IDE/Core/RuleTypes.hs +++ b/src/Development/IDE/Core/RuleTypes.hs @@ -12,6 +12,7 @@ -- using the "Shaker" abstraction layer for in-memory use. -- module Development.IDE.Core.RuleTypes( + GhcSessionDeps(.., GhcSessionDeps), module Development.IDE.Core.RuleTypes ) where @@ -42,7 +43,8 @@ import Development.IDE.Spans.LocalBindings import Development.IDE.Types.Diagnostics import GHC.Serialized (Serialized) -import Language.LSP.Types (NormalizedFilePath) +import Language.LSP.Types (Int32, + NormalizedFilePath) data LinkableType = ObjectLinkable | BCOLinkable deriving (Eq,Ord,Show, Generic) @@ -289,13 +291,13 @@ type instance RuleResult GetModificationTime = FileVersion data FileVersion - = VFSVersion !Int + = VFSVersion !Int32 | ModificationTime !POSIXTime deriving (Show, Generic) instance NFData FileVersion -vfsVersion :: FileVersion -> Maybe Int +vfsVersion :: FileVersion -> Maybe Int32 vfsVersion (VFSVersion i) = Just i vfsVersion ModificationTime{} = Nothing @@ -407,9 +409,15 @@ instance Hashable GhcSession instance NFData GhcSession -data GhcSessionDeps = GhcSessionDeps deriving (Eq, Show, Typeable, Generic) -instance Hashable GhcSessionDeps -instance NFData GhcSessionDeps +newtype GhcSessionDeps = GhcSessionDeps_ + { -- | Load full ModSummary values in the GHC session. + -- Required for interactive evaluation, but leads to more cache invalidations + fullModSummary :: Bool + } + deriving newtype (Eq, Show, Typeable, Hashable, NFData) + +pattern GhcSessionDeps :: GhcSessionDeps +pattern GhcSessionDeps = GhcSessionDeps_ False data GetModIfaceFromDisk = GetModIfaceFromDisk deriving (Eq, Show, Typeable, Generic) diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -76,7 +76,6 @@ import qualified Data.Aeson.Types as A import qualified Data.Binary as B import qualified Data.ByteString as BS -import Data.ByteString.Encoding as T import qualified Data.ByteString.Lazy as LBS import Data.Coerce import Data.Foldable @@ -106,8 +105,7 @@ import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat.Env -import Development.IDE.GHC.Compat.Core hiding +import Development.IDE.GHC.Compat hiding (parseModule, TargetId(..), loadInterface, @@ -131,14 +129,13 @@ import qualified Development.IDE.Types.Logger as L import Development.IDE.Types.Options import GHC.Generics (Generic) -import GHC.IO.Encoding import qualified GHC.LanguageExtensions as LangExt import qualified HieDb import Ide.Plugin.Config import qualified Language.LSP.Server as LSP -import Language.LSP.Types (SMethod (SCustomMethod)) +import Language.LSP.Types (SMethod (SCustomMethod, SWindowShowMessage), ShowMessageParams (ShowMessageParams), MessageType (MtInfo)) import Language.LSP.VFS -import System.Directory (canonicalizePath, makeAbsolute) +import System.Directory (makeAbsolute) import Data.Default (def, Default) import Ide.Plugin.Properties (HasProperty, KeyNameProxy, @@ -148,7 +145,14 @@ import Ide.PluginUtils (configForPlugin) 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) +templateHaskellInstructions :: T.Text +templateHaskellInstructions = "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. @@ -513,21 +517,20 @@ getHieAstsRule = define $ \GetHieAst f -> do tmr <- use_ TypeCheck f - hsc <- hscEnv <$> use_ GhcSession f + hsc <- hscEnv <$> use_ GhcSessionDeps f getHieAstRuleDefinition f hsc tmr persistentHieFileRule :: Rules () persistentHieFileRule = addPersistentRule GetHieAst $ \file -> runMaybeT $ do res <- readHieFileForSrcFromDisk file vfs <- asks vfs - encoding <- liftIO getLocaleEncoding (currentSource,ver) <- liftIO $ do mvf <- getVirtualFile vfs $ filePathToUri' file case mvf of - Nothing -> (,Nothing) . T.decode encoding <$> BS.readFile (fromNormalizedFilePath file) + Nothing -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file) Just vf -> pure (Rope.toText $ _text vf, Just $ _lsp_version vf) let refmap = Compat.generateReferencesMap . Compat.getAsts . Compat.hie_asts $ res - del = deltaFromDiff (T.decode encoding $ Compat.hie_hs_src res) currentSource + del = deltaFromDiff (T.decodeUtf8 $ Compat.hie_hs_src res) currentSource pure (HAR (Compat.hie_module res) (Compat.hie_asts res) refmap mempty (HieFromDisk res),del,ver) getHieAstRuleDefinition :: NormalizedFilePath -> HscEnv -> TcModuleResult -> Action (IdeResult HieAstResult) @@ -589,9 +592,9 @@ readHieFileForSrcFromDisk :: NormalizedFilePath -> MaybeT IdeAction Compat.HieFile readHieFileForSrcFromDisk file = do - db <- asks hiedb + ShakeExtras{withHieDb} <- ask log <- asks $ L.logDebug . logger - row <- MaybeT $ liftIO $ HieDb.lookupHieFileFromSource db $ fromNormalizedFilePath file + row <- MaybeT $ liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb $ fromNormalizedFilePath file) let hie_loc = HieDb.hieModuleHieFile row liftIO $ log $ "LOADING HIE FILE :" <> T.pack (show file) exceptToMaybeT $ readHieFileFromDisk hie_loc @@ -696,22 +699,23 @@ Nothing -> LBS.toStrict $ B.encode (hash (snd val)) return (Just cutoffHash, val) - defineNoDiagnostics $ \GhcSessionDeps file -> do + defineNoDiagnostics $ \(GhcSessionDeps_ fullModSummary) file -> do env <- use_ GhcSession file - ghcSessionDepsDefinition ghcSessionDepsConfig env file + ghcSessionDepsDefinition fullModSummary ghcSessionDepsConfig env file -data GhcSessionDepsConfig = GhcSessionDepsConfig +newtype GhcSessionDepsConfig = GhcSessionDepsConfig { checkForImportCycles :: Bool - , fullModSummary :: Bool } instance Default GhcSessionDepsConfig where def = GhcSessionDepsConfig { checkForImportCycles = True - , fullModSummary = False } -ghcSessionDepsDefinition :: GhcSessionDepsConfig -> HscEnvEq -> NormalizedFilePath -> Action (Maybe HscEnvEq) -ghcSessionDepsDefinition GhcSessionDepsConfig{..} env file = do +ghcSessionDepsDefinition + :: -- | full mod summary + Bool -> + GhcSessionDepsConfig -> HscEnvEq -> NormalizedFilePath -> Action (Maybe HscEnvEq) +ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do let hsc = hscEnv env mbdeps <- mapM(fmap artifactFilePath . snd) <$> use_ GetLocatedImports file @@ -723,7 +727,7 @@ then uses_ GetModSummary deps else uses_ GetModSummaryWithoutTimestamps deps - depSessions <- map hscEnv <$> uses_ GhcSessionDeps deps + depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) deps ifaces <- uses_ GetModIface deps let inLoadOrder = map hirHomeMod ifaces @@ -762,14 +766,14 @@ -- doesn't need early cutoff since all its dependencies already have it defineNoDiagnostics $ \GetModIfaceFromDiskAndIndex f -> do x <- use_ GetModIfaceFromDisk f - se@ShakeExtras{hiedb} <- getShakeExtras + se@ShakeExtras{withHieDb} <- getShakeExtras -- GetModIfaceFromDisk should have written a `.hie` file, must check if it matches version in db let ms = hirModSummary x hie_loc = Compat.ml_hie_file $ ms_location ms hash <- liftIO $ Util.getFileHash hie_loc - mrow <- liftIO $ HieDb.lookupHieFileFromSource hiedb (fromNormalizedFilePath f) - hie_loc' <- liftIO $ traverse (canonicalizePath . HieDb.hieModuleHieFile) mrow + mrow <- liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb (fromNormalizedFilePath f)) + hie_loc' <- liftIO $ traverse (makeAbsolute . HieDb.hieModuleHieFile) mrow case mrow of Just row | hash == HieDb.modInfoHash (HieDb.hieModInfo row) @@ -818,8 +822,26 @@ summarize SourceUnmodified = BS.singleton 2 summarize SourceUnmodifiedAndStable = BS.singleton 3 +displayTHWarning :: LspT c IO () +displayTHWarning + | not isWindows && not hostIsDynamic = do + LSP.sendNotification SWindowShowMessage $ + ShowMessageParams MtInfo $ T.unwords + [ "This HLS binary does not support Template Haskell." + , "Follow the [instructions](" <> templateHaskellInstructions <> ")" + , "to build an HLS binary with support for Template Haskell." + ] + | otherwise = return () + +newtype DisplayTHWarning = DisplayTHWarning (IO ()) +instance IsIdeGlobal DisplayTHWarning + getModSummaryRule :: Rules () getModSummaryRule = do + env <- lspEnv <$> getShakeExtrasRules + displayItOnce <- liftIO $ once $ LSP.runLspT (fromJust env) displayTHWarning + addIdeGlobal (DisplayTHWarning displayItOnce) + defineEarlyCutoff $ Rule $ \GetModSummary f -> do session' <- hscEnv <$> use_ GhcSession f modify_dflags <- getModifyDynFlags dynFlagsModifyGlobal @@ -830,6 +852,10 @@ getModSummaryFromImports session fp modTime (textToStringBuffer <$> mFileContent) case modS of Right res -> do + -- Check for Template Haskell + when (uses_th_qq $ msrModSummary res) $ do + DisplayTHWarning act <- getIdeGlobalAction + liftIO act bufFingerPrint <- liftIO $ fingerprintFromStringBuffer $ fromJust $ ms_hspp_buf $ msrModSummary res let fingerPrint = Util.fingerprintFingerprints @@ -1025,9 +1051,6 @@ pure (Just $ encodeLinkableType res, Just res) where - uses_th_qq (ms_hspp_opts -> dflags) = - xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags - computeLinkableType :: ModSummary -> [Maybe ModSummary] -> [Maybe LinkableType] -> Maybe LinkableType computeLinkableType this deps xs | Just ObjectLinkable `elem` xs = Just ObjectLinkable -- If any dependent needs object code, so do we @@ -1037,6 +1060,10 @@ where this_type = computeLinkableTypeForDynFlags (ms_hspp_opts this) +uses_th_qq :: ModSummary -> Bool +uses_th_qq (ms_hspp_opts -> dflags) = + xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes 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 @@ -1061,7 +1088,7 @@ extras <- getShakeExtras let targetPath = Compat.ml_hi_file $ ms_location $ hirModSummary hiFile liftIO $ do - resetInterfaceStore extras $ toNormalizedFilePath' targetPath + atomically $ resetInterfaceStore extras $ toNormalizedFilePath' targetPath writeHiFile hsc hiFile data RulesConfig = RulesConfig diff --git a/src/Development/IDE/Core/Service.hs b/src/Development/IDE/Core/Service.hs --- a/src/Development/IDE/Core/Service.hs +++ b/src/Development/IDE/Core/Service.hs @@ -30,7 +30,8 @@ import Control.Monad import Development.IDE.Core.Shake -import System.Environment (lookupEnv) +import Development.IDE.Types.Shake (WithHieDb) +import System.Environment (lookupEnv) ------------------------------------------------------------ @@ -44,10 +45,10 @@ -> Debouncer LSP.NormalizedUri -> IdeOptions -> VFSHandle - -> HieDb + -> WithHieDb -> IndexQueue -> IO IdeState -initialise defaultConfig mainRule lspEnv logger debouncer options vfs hiedb hiedbChan = do +initialise defaultConfig mainRule lspEnv logger debouncer options vfs withHieDb hiedbChan = do shakeProfiling <- do let fromConf = optShakeProfiling options fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING" @@ -60,7 +61,7 @@ shakeProfiling (optReportProgress options) (optTesting options) - hiedb + withHieDb hiedbChan vfs (optShakeOptions options) diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs --- a/src/Development/IDE/Core/Shake.hs +++ b/src/Development/IDE/Core/Shake.hs @@ -5,6 +5,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecursiveDo #-} @@ -147,24 +148,26 @@ import Language.LSP.Types.Capabilities import OpenTelemetry.Eventlog +import Control.Concurrent.STM.Stats (atomicallyNamed) import Control.Exception.Extra hiding (bracket_) import Data.Aeson (toJSON) import qualified Data.ByteString.Char8 as BS8 import Data.Coerce (coerce) import Data.Default -import Data.Foldable (toList) +import Data.Foldable (for_, toList) import Data.HashSet (HashSet) import qualified Data.HashSet as HSet -import Data.IORef.Extra (atomicModifyIORef'_, - atomicModifyIORef_) import Data.String (fromString) import Data.Text (pack) import Debug.Trace.Flags (userTracingEnabled) import qualified Development.IDE.Types.Exports as ExportsMap +import qualified Focus import HieDb.Types import Ide.Plugin.Config import qualified Ide.PluginUtils as HLS import Ide.Types (PluginId) +import qualified "list-t" ListT +import qualified StmContainers.Map as STM -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by @@ -179,7 +182,9 @@ } -- | Actions to queue up on the index worker thread -type IndexQueue = TQueue (HieDb -> IO ()) +-- The inner `(HieDb -> IO ()) -> IO ()` wraps `HieDb -> IO ()` +-- with (currently) retry functionality +type IndexQueue = TQueue (((HieDb -> IO ()) -> IO ()) -> IO ()) -- information we stash inside the shakeExtra field data ShakeExtras = ShakeExtras @@ -187,14 +192,16 @@ lspEnv :: Maybe (LSP.LanguageContextEnv Config) ,debouncer :: Debouncer NormalizedUri ,logger :: Logger - ,globals :: Var (HMap.HashMap TypeRep Dynamic) - ,state :: Var Values - ,diagnostics :: Var DiagnosticStore - ,hiddenDiagnostics :: Var DiagnosticStore - ,publishedDiagnostics :: Var (HMap.HashMap NormalizedUri [Diagnostic]) + ,globals :: TVar (HMap.HashMap TypeRep Dynamic) + -- ^ Registry of global state used by rules. + -- Small and immutable after startup, so not worth using an STM.Map. + ,state :: Values + ,diagnostics :: STMDiagnosticStore + ,hiddenDiagnostics :: STMDiagnosticStore + ,publishedDiagnostics :: STM.Map NormalizedUri [Diagnostic] -- ^ This represents the set of diagnostics that we have published. -- Due to debouncing not every change might get published. - ,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping))) + ,positionMapping :: STM.Map NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping)) -- ^ Map from a text document version to a PositionMapping that describes how to map -- positions in a version of that document to positions in the latest version -- First mapping is delta from previous version and second one is an @@ -208,21 +215,22 @@ -> IO () ,ideNc :: IORef NameCache -- | A mapping of module name to known target (or candidate targets, if missing) - ,knownTargetsVar :: Var (Hashed KnownTargets) + ,knownTargetsVar :: TVar (Hashed KnownTargets) -- | A mapping of exported identifiers for local modules. Updated on kick - ,exportsMap :: Var ExportsMap + ,exportsMap :: TVar ExportsMap -- | A work queue for actions added via 'runInShakeSession' ,actionQueue :: ActionQueue ,clientCapabilities :: ClientCapabilities - , hiedb :: HieDb -- ^ Use only to read. + , withHieDb :: WithHieDb -- ^ Use only to read. , hiedbWriter :: HieDbWriter -- ^ use to write - , persistentKeys :: Var (HMap.HashMap Key GetStalePersistent) + , persistentKeys :: TVar (HMap.HashMap Key GetStalePersistent) -- ^ Registery for functions that compute/get "stale" results for the rule -- (possibly from disk) + -- Small and immutable after startup, so not worth using an STM.Map. , vfs :: VFSHandle , defaultConfig :: Config -- ^ Default HLS config, only relevant if the client does not provide any Config - , dirtyKeys :: IORef (HashSet Key) + , dirtyKeys :: TVar (HashSet Key) -- ^ Set of dirty rule keys since the last Shake run } @@ -256,7 +264,7 @@ addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,TextDocumentVersion))) -> Rules () addPersistentRule k getVal = do ShakeExtras{persistentKeys} <- getShakeExtrasRules - void $ liftIO $ modifyVar' persistentKeys $ HMap.insert (Key k) (fmap (fmap (first3 toDyn)) . getVal) + void $ liftIO $ atomically $ modifyTVar' persistentKeys $ HMap.insert (Key k) (fmap (fmap (first3 toDyn)) . getVal) class Typeable a => IsIdeGlobal a where @@ -280,15 +288,15 @@ addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO () addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) = - void $ liftIO $ modifyVarIO' globals $ \mp -> case HMap.lookup ty mp of - Just _ -> errorIO $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty - Nothing -> return $! HMap.insert ty (toDyn x) mp + void $ liftIO $ atomically $ modifyTVar' globals $ \mp -> case HMap.lookup ty mp of + Just _ -> error $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty + Nothing -> HMap.insert ty (toDyn x) mp getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a getIdeGlobalExtras ShakeExtras{globals} = do let typ = typeRep (Proxy :: Proxy a) - x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals + x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readTVarIO globals case x of Just x | Just x <- fromDynamic x -> pure x @@ -308,7 +316,14 @@ getIdeOptions :: Action IdeOptions getIdeOptions = do GlobalIdeOptions x <- getIdeGlobalAction - return x + env <- lspEnv <$> getShakeExtras + case env of + Nothing -> return x + Just env -> do + config <- liftIO $ LSP.runLspT env HLS.getClientConfig + return x{optCheckProject = pure $ checkProject config, + optCheckParents = pure $ checkParents config + } getIdeOptionsIO :: ShakeExtras -> IO IdeOptions getIdeOptionsIO ide = do @@ -319,26 +334,24 @@ -- for the version of that value. lastValueIO :: IdeRule k v => ShakeExtras -> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping)) lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do - hm <- readVar state - allMappings <- readVar positionMapping let readPersistent | IdeTesting testing <- ideTesting s -- Don't read stale persistent values in tests , testing = pure Nothing | otherwise = do - pmap <- readVar persistentKeys + pmap <- readTVarIO persistentKeys mv <- runMaybeT $ do liftIO $ Logger.logDebug (logger s) $ T.pack $ "LOOKUP UP PERSISTENT FOR: " ++ show k f <- MaybeT $ pure $ HMap.lookup (Key k) pmap (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file MaybeT $ pure $ (,del,ver) <$> fromDynamic dv - case mv of + atomicallyNamed "lastValueIO" $ case mv of Nothing -> do - void $ modifyVar' state $ HMap.alter (alterValue $ Failed True) (toKey k file) + STM.focus (Focus.alter (alterValue $ Failed True)) (toKey k file) state return Nothing Just (v,del,ver) -> do - void $ modifyVar' state $ HMap.alter (alterValue $ Stale (Just del) ver (toDyn v)) (toKey k file) - return $ Just (v,addDelta del $ mappingForVersion allMappings file ver) + STM.focus (Focus.alter (alterValue $ Stale (Just del) ver (toDyn v))) (toKey k file) state + Just . (v,) . addDelta del <$> mappingForVersion positionMapping file ver -- We got a new stale value from the persistent rule, insert it in the map without affecting diagnostics alterValue new Nothing = Just (ValueWithDiagnostics new mempty) -- If it wasn't in the map, give it empty diagnostics @@ -348,11 +361,13 @@ -- Something already succeeded before, leave it alone _ -> old - case HMap.lookup (toKey k file) hm of + atomicallyNamed "lastValueIO 4" (STM.lookup (toKey k file) state) >>= \case Nothing -> readPersistent Just (ValueWithDiagnostics v _) -> case v of - Succeeded ver (fromDynamic -> Just v) -> pure (Just (v, mappingForVersion allMappings file ver)) - Stale del ver (fromDynamic -> Just v) -> pure (Just (v, maybe id addDelta del $ mappingForVersion allMappings file ver)) + Succeeded ver (fromDynamic -> Just v) -> + atomicallyNamed "lastValueIO 5" $ Just . (v,) <$> mappingForVersion positionMapping file ver + Stale del ver (fromDynamic -> Just v) -> + atomicallyNamed "lastValueIO 6" $ Just . (v,) . maybe id addDelta del <$> mappingForVersion positionMapping file ver Failed p | not p -> readPersistent _ -> pure Nothing @@ -364,14 +379,13 @@ liftIO $ lastValueIO s key file mappingForVersion - :: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping)) + :: STM.Map NormalizedUri (Map TextDocumentVersion (a, PositionMapping)) -> NormalizedFilePath -> TextDocumentVersion - -> PositionMapping -mappingForVersion allMappings file ver = - maybe zeroMapping snd $ - Map.lookup ver =<< - HMap.lookup (filePathToUri' file) allMappings + -> STM PositionMapping +mappingForVersion allMappings file ver = do + mapping <- STM.lookup (filePathToUri' file) allMappings + return $ maybe zeroMapping snd $ Map.lookup ver =<< mapping type IdeRule k v = ( Shake.RuleResult k ~ v @@ -413,14 +427,14 @@ return (dir file) setValues :: IdeRule k v - => Var Values + => Values -> k -> NormalizedFilePath -> Value v -> Vector FileDiagnostic - -> IO () + -> STM () setValues state key file val diags = - void $ modifyVar' state $ HMap.insert (toKey key file) (ValueWithDiagnostics (fmap toDyn val) diags) + STM.insert (ValueWithDiagnostics (fmap toDyn val) diags) (toKey key file) state -- | Delete the value stored for a given ide build key @@ -429,55 +443,55 @@ => ShakeExtras -> k -> NormalizedFilePath - -> IO () + -> STM () deleteValue ShakeExtras{dirtyKeys, state} key file = do - void $ modifyVar' state $ HMap.delete (toKey key file) - atomicModifyIORef_ dirtyKeys $ HSet.insert (toKey key file) + STM.delete (toKey key file) state + modifyTVar' dirtyKeys $ HSet.insert (toKey key file) recordDirtyKeys :: Shake.ShakeValue k => ShakeExtras -> k -> [NormalizedFilePath] - -> IO () -recordDirtyKeys ShakeExtras{dirtyKeys} key file = withEventTrace "recordDirtyKeys" $ \addEvent -> do - atomicModifyIORef_ dirtyKeys $ \x -> foldl' (flip HSet.insert) x (toKey key <$> file) - addEvent (fromString $ "dirty " <> show key) (fromString $ unlines $ map fromNormalizedFilePath file) - + -> STM (IO ()) +recordDirtyKeys ShakeExtras{dirtyKeys} key file = do + modifyTVar' dirtyKeys $ \x -> foldl' (flip HSet.insert) x (toKey key <$> file) + return $ withEventTrace "recordDirtyKeys" $ \addEvent -> do + addEvent (fromString $ unlines $ "dirty " <> show key : map fromNormalizedFilePath file) -- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value. getValues :: forall k v. IdeRule k v => - Var Values -> + Values -> k -> NormalizedFilePath -> - IO (Maybe (Value v, Vector FileDiagnostic)) + STM (Maybe (Value v, Vector FileDiagnostic)) getValues state key file = do - vs <- readVar state - case HMap.lookup (toKey key file) vs of + STM.lookup (toKey key file) state >>= \case Nothing -> pure Nothing Just (ValueWithDiagnostics v diagsV) -> do - let r = fmap (fromJust . fromDynamic @v) v + let !r = seqValue $ fmap (fromJust . fromDynamic @v) v + !res = (r,diagsV) -- Force to make sure we do not retain a reference to the HashMap -- and we blow up immediately if the fromJust should fail -- (which would be an internal error). - evaluate (r `seqValue` Just (r, diagsV)) + return $ Just res -- | Get all the files in the project knownTargets :: Action (Hashed KnownTargets) knownTargets = do ShakeExtras{knownTargetsVar} <- getShakeExtras - liftIO $ readVar knownTargetsVar + liftIO $ readTVarIO knownTargetsVar -- | Seq the result stored in the Shake value. This only -- evaluates the value to WHNF not NF. We take care of the latter -- elsewhere and doing it twice is expensive. -seqValue :: Value v -> b -> b -seqValue v b = case v of - Succeeded ver v -> rnf ver `seq` v `seq` b - Stale d ver v -> rnf d `seq` rnf ver `seq` v `seq` b - Failed _ -> b +seqValue :: Value v -> Value v +seqValue val = case val of + Succeeded ver v -> rnf ver `seq` v `seq` val + Stale d ver v -> rnf d `seq` rnf ver `seq` v `seq` val + Failed _ -> val -- | Open a 'IdeState', should be shut using 'shakeShut'. shakeOpen :: Maybe (LSP.LanguageContextEnv Config) @@ -487,37 +501,37 @@ -> Maybe FilePath -> IdeReportProgress -> IdeTesting - -> HieDb + -> WithHieDb -> IndexQueue -> VFSHandle -> ShakeOptions -> Rules () -> IO IdeState shakeOpen lspEnv defaultConfig logger debouncer - shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) hiedb indexQueue vfs opts rules = mdo + shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) withHieDb indexQueue vfs opts rules = mdo us <- mkSplitUniqSupply 'r' ideNc <- newIORef (initNameCache us knownKeyNames) shakeExtras <- do - globals <- newVar HMap.empty - state <- newVar HMap.empty - diagnostics <- newVar mempty - hiddenDiagnostics <- newVar mempty - publishedDiagnostics <- newVar mempty - positionMapping <- newVar HMap.empty - knownTargetsVar <- newVar $ hashed HMap.empty + globals <- newTVarIO HMap.empty + state <- STM.newIO + diagnostics <- STM.newIO + hiddenDiagnostics <- STM.newIO + publishedDiagnostics <- STM.newIO + positionMapping <- STM.newIO + knownTargetsVar <- newTVarIO $ hashed HMap.empty let restartShakeSession = shakeRestart ideState - persistentKeys <- newVar HMap.empty + persistentKeys <- newTVarIO HMap.empty indexPending <- newTVarIO HMap.empty indexCompleted <- newTVarIO 0 indexProgressToken <- newVar Nothing let hiedbWriter = HieDbWriter{..} - exportsMap <- newVar mempty + exportsMap <- newTVarIO mempty -- lazily initialize the exports map with the contents of the hiedb _ <- async $ do logDebug logger "Initializing exports map from hiedb" - em <- createExportsMapHieDb hiedb - modifyVar' exportsMap (<> em) + em <- createExportsMapHieDb withHieDb + atomically $ modifyTVar' exportsMap (<> em) logDebug logger $ "Done initializing exports map from hiedb (" <> pack(show (ExportsMap.size em)) <> ")" progress <- do @@ -529,7 +543,7 @@ let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv - dirtyKeys <- newIORef mempty + dirtyKeys <- newTVarIO mempty pure ShakeExtras{..} (shakeDbM, shakeClose) <- shakeOpenDatabase @@ -559,8 +573,8 @@ IdeOptions{optCheckParents} <- getIdeOptionsIO extras checkParents <- optCheckParents regularly 1 $ do - readVar state >>= observe countKeys . countRelevantKeys checkParents . HMap.keys - readIORef dirtyKeys >>= observe countDirty . countRelevantKeys checkParents . HSet.toList + observe countKeys . countRelevantKeys checkParents . map fst =<< (atomically . ListT.toList . STM.listT) state + readTVarIO dirtyKeys >>= observe countDirty . countRelevantKeys checkParents . HSet.toList shakeGetBuildStep db >>= observe countBuilds | otherwise = async (pure ()) @@ -571,15 +585,17 @@ -- | Must be called in the 'Initialized' handler and only once shakeSessionInit :: IdeState -> IO () -shakeSessionInit IdeState{..} = do +shakeSessionInit ide@IdeState{..} = do initSession <- newSession shakeExtras shakeDb [] "shakeSessionInit" putMVar shakeSession initSession + logDebug (ideLogger ide) "Shake session initialized" shakeShut :: IdeState -> IO () -shakeShut IdeState{..} = withMVar shakeSession $ \runner -> do +shakeShut IdeState{..} = do + runner <- tryReadMVar shakeSession -- Shake gets unhappy if you try to close when there is a running -- request so we first abort that. - void $ cancelShakeSession runner + for_ runner cancelShakeSession void $ shakeDatabaseProfile shakeDb shakeClose progressStop $ progress shakeExtras @@ -617,8 +633,8 @@ (\runner -> do (stopTime,()) <- duration (cancelShakeSession runner) res <- shakeDatabaseProfile shakeDb - backlog <- readIORef $ dirtyKeys shakeExtras - queue <- atomically $ peekInProgress $ actionQueue shakeExtras + backlog <- readTVarIO $ dirtyKeys shakeExtras + queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras let profile = case res of Just fp -> ", profile saved at " <> fp _ -> "" @@ -651,7 +667,7 @@ shakeEnqueue :: ShakeExtras -> DelayedAction a -> IO (IO a) shakeEnqueue ShakeExtras{actionQueue, logger} act = do (b, dai) <- instantiateDelayedAction act - atomically $ pushQueue dai actionQueue + atomicallyNamed "actionQueue - push" $ pushQueue dai actionQueue let wait' b = waitBarrier b `catches` [ Handler(\BlockedIndefinitelyOnMVar -> @@ -660,7 +676,7 @@ , Handler (\e@AsyncCancelled -> do logPriority logger Debug $ T.pack $ actionName act <> " was cancelled" - atomically $ abortQueue dai actionQueue + atomicallyNamed "actionQueue - abort" $ abortQueue dai actionQueue throw e) ] return (wait' b >>= either throwIO return) @@ -675,29 +691,28 @@ -> IO ShakeSession newSession extras@ShakeExtras{..} shakeDb acts reason = do IdeOptions{optRunSubset} <- getIdeOptionsIO extras - reenqueued <- atomically $ peekInProgress actionQueue + reenqueued <- atomicallyNamed "actionQueue - peek" $ peekInProgress actionQueue allPendingKeys <- if optRunSubset - then Just <$> readIORef dirtyKeys + then Just <$> readTVarIO dirtyKeys else return Nothing let -- A daemon-like action used to inject additional work -- Runs actions from the work queue sequentially pumpActionThread otSpan = do - d <- liftIO $ atomically $ popQueue actionQueue + d <- liftIO $ atomicallyNamed "action queue - pop" $ popQueue actionQueue actionFork (run otSpan d) $ \_ -> pumpActionThread otSpan -- TODO figure out how to thread the otSpan into defineEarlyCutoff run _otSpan d = do start <- liftIO offsetTime getAction d - liftIO $ atomically $ doneQueue d actionQueue + liftIO $ atomicallyNamed "actionQueue - done" $ doneQueue d actionQueue runTime <- liftIO start let msg = T.pack $ "finish: " ++ actionName d ++ " (took " ++ showDuration runTime ++ ")" liftIO $ do logPriority logger (actionPriority d) msg - notifyTestingLogMessage extras msg -- The inferred type signature doesn't work in ghc >= 9.0.1 workRun :: (forall b. IO b -> IO b) -> IO (IO ()) @@ -748,15 +763,13 @@ d' = DelayedAction (Just u) s p a' return (b, d') -getDiagnostics :: IdeState -> IO [FileDiagnostic] +getDiagnostics :: IdeState -> STM [FileDiagnostic] getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do - val <- readVar diagnostics - return $ getAllDiagnostics val + getAllDiagnostics diagnostics -getHiddenDiagnostics :: IdeState -> IO [FileDiagnostic] +getHiddenDiagnostics :: IdeState -> STM [FileDiagnostic] getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do - val <- readVar hiddenDiagnostics - return $ getAllDiagnostics val + getAllDiagnostics hiddenDiagnostics -- | Find and release old keys from the state Hashmap -- For the record, there are other state sources that this process does not release: @@ -778,29 +791,30 @@ garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key] garbageCollectKeys label maxAge checkParents agedKeys = do start <- liftIO offsetTime - extras <- getShakeExtras - (n::Int, garbage) <- liftIO $ modifyVar (state extras) $ \vmap -> - evaluate $ foldl' removeDirtyKey (vmap, (0,[])) agedKeys - liftIO $ atomicModifyIORef_ (dirtyKeys extras) $ \x -> - foldl' (flip HSet.insert) x garbage + ShakeExtras{state, dirtyKeys, lspEnv, logger, ideTesting} <- getShakeExtras + (n::Int, garbage) <- liftIO $ + foldM (removeDirtyKey dirtyKeys state) (0,[]) agedKeys t <- liftIO start when (n>0) $ liftIO $ do - logDebug (logger extras) $ T.pack $ + logDebug logger $ T.pack $ label <> " of " <> show n <> " keys (took " <> showDuration t <> ")" - when (coerce $ ideTesting extras) $ liftIO $ mRunLspT (lspEnv extras) $ + when (coerce ideTesting) $ liftIO $ mRunLspT lspEnv $ LSP.sendNotification (SCustomMethod "ghcide/GC") (toJSON $ mapMaybe (fmap showKey . fromKeyType) garbage) return garbage where showKey = show . Q - removeDirtyKey st@(vmap,(!counter, keys)) (k, age) + removeDirtyKey dk values st@(!counter, keys) (k, age) | age > maxAge , Just (kt,_) <- fromKeyType k , not(kt `HSet.member` preservedKeys checkParents) - , (True, vmap') <- HMap.alterF (\prev -> (isJust prev, Nothing)) k vmap - = (vmap', (counter+1, k:keys)) - | otherwise = st + = atomicallyNamed "GC" $ do + gotIt <- STM.focus (Focus.member <* Focus.delete) k values + when gotIt $ + modifyTVar' dk (HSet.insert k) + return $ if gotIt then (counter+1, k:keys) else st + | otherwise = pure st countRelevantKeys :: CheckParents -> [Key] -> Int countRelevantKeys checkParents = @@ -899,7 +913,7 @@ wait <- delayedAction $ mkDelayedAction ("C:" ++ show key ++ ":" ++ fromNormalizedFilePath file) Debug $ use key file s@ShakeExtras{state} <- askShake - r <- liftIO $ getValues state key file + r <- liftIO $ atomicallyNamed "useStateFast" $ getValues state key file liftIO $ case r of -- block for the result if we haven't computed before Nothing -> do @@ -1008,7 +1022,7 @@ (if optSkipProgress options key then id else inProgress progress file) $ do val <- case old of Just old | mode == RunDependenciesSame -> do - v <- liftIO $ getValues state key file + v <- liftIO $ atomicallyNamed "define - read 1" $ getValues state key file case v of -- No changes in the dependencies and we have -- an existing successful result. @@ -1027,10 +1041,10 @@ (do v <- action; liftIO $ evaluate $ force v) $ \(e :: SomeException) -> do pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing)) - modTime <- liftIO $ (currentValue . fst =<<) <$> getValues state GetModificationTime file + modTime <- liftIO $ (currentValue . fst =<<) <$> atomicallyNamed "define - read 2" (getValues state GetModificationTime file) (bs, res) <- case res of Nothing -> do - staleV <- liftIO $ getValues state key file + staleV <- liftIO $ atomicallyNamed "define -read 3" $ getValues state key file pure $ case staleV of Nothing -> (toShakeValue ShakeResult bs, Failed False) Just v -> case v of @@ -1041,7 +1055,7 @@ (Failed b, _) -> (toShakeValue ShakeResult bs, Failed b) Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v) - liftIO $ setValues state key file res (Vector.fromList diags) + liftIO $ atomicallyNamed "define - write" $ setValues state key file res (Vector.fromList diags) doDiagnostics diags let eq = case (bs, fmap decodeShakeValue old) of (ShakeResult a, Just (ShakeResult b)) -> cmp a b @@ -1053,7 +1067,7 @@ (if eq then ChangedRecomputeSame else ChangedRecomputeDiff) (encodeShakeValue bs) $ A res - liftIO $ atomicModifyIORef'_ dirtyKeys (HSet.delete $ toKey key file) + liftIO $ atomicallyNamed "define - dirtyKeys" $ modifyTVar' dirtyKeys (HSet.delete $ toKey key file) return res traceA :: A v -> String @@ -1141,34 +1155,30 @@ -> [(ShowDiagnostic,Diagnostic)] -- ^ current results -> m () updateFileDiagnostics fp k ShakeExtras{logger, diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, lspEnv} current = liftIO $ do - modTime <- (currentValue . fst =<<) <$> getValues state GetModificationTime fp + modTime <- (currentValue . fst =<<) <$> atomicallyNamed "diagnostics - read" (getValues state GetModificationTime fp) let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current uri = filePathToUri' fp ver = vfsVersion =<< modTime - update new store = - let store' = setStageDiagnostics uri ver (T.pack $ show k) new store - new' = getUriDiagnostics uri store' - in (store', new') + update new store = setStageDiagnostics uri ver (T.pack $ show k) new store mask_ $ do -- Mask async exceptions to ensure that updated diagnostics are always -- published. Otherwise, we might never publish certain diagnostics if -- an exception strikes between modifyVar but before -- publishDiagnosticsNotification. - newDiags <- modifyVar diagnostics $ pure . update (map snd currentShown) - _ <- modifyVar hiddenDiagnostics $ pure . update (map snd currentHidden) + newDiags <- liftIO $ atomicallyNamed "diagnostics - update" $ update (map snd currentShown) diagnostics + _ <- liftIO $ atomicallyNamed "diagnostics - hidden" $ update (map snd currentHidden) hiddenDiagnostics let uri = filePathToUri' fp let delay = if null newDiags then 0.1 else 0 registerEvent debouncer delay uri $ do - join $ mask_ $ modifyVar publishedDiagnostics $ \published -> do - let lastPublish = HMap.lookupDefault [] uri published - !published' = HMap.insert uri newDiags published - action = when (lastPublish /= newDiags) $ case lspEnv of + join $ mask_ $ do + lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri publishedDiagnostics + let action = when (lastPublish /= newDiags) $ case lspEnv of Nothing -> -- Print an LSP event. logInfo logger $ showDiagnosticsColored $ map (fp,ShowDiag,) newDiags Just env -> LSP.runLspT env $ LSP.sendNotification LSP.STextDocumentPublishDiagnostics $ - LSP.PublishDiagnosticsParams (fromNormalizedUri uri) ver (List newDiags) - return (published', action) + LSP.PublishDiagnosticsParams (fromNormalizedUri uri) (fmap fromIntegral ver) (List newDiags) + return action newtype Priority = Priority Double @@ -1183,10 +1193,21 @@ ShakeExtras{logger} <- getShakeExtras return logger +-------------------------------------------------------------------------------- +type STMDiagnosticStore = STM.Map NormalizedUri StoreItem getDiagnosticsFromStore :: StoreItem -> [Diagnostic] getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags +updateSTMDiagnostics :: STMDiagnosticStore + -> NormalizedUri -> TextDocumentVersion -> DiagnosticsBySource + -> STM [LSP.Diagnostic] +updateSTMDiagnostics store uri mv newDiagsBySource = + getDiagnosticsFromStore . fromJust <$> STM.focus (Focus.alter update *> Focus.lookup) uri store + where + update (Just(StoreItem mvs dbs)) + | mvs == mv = Just (StoreItem mv (newDiagsBySource <> dbs)) + update _ = Just (StoreItem mv newDiagsBySource) -- | Sets the diagnostics for a file and compilation step -- if you want to clear the diagnostics call this with an empty list @@ -1195,38 +1216,29 @@ -> TextDocumentVersion -- ^ the time that the file these diagnostics originate from was last edited -> T.Text -> [LSP.Diagnostic] - -> DiagnosticStore - -> DiagnosticStore -setStageDiagnostics uri ver stage diags ds = updateDiagnostics ds uri ver updatedDiags + -> STMDiagnosticStore + -> STM [LSP.Diagnostic] +setStageDiagnostics uri ver stage diags ds = updateSTMDiagnostics ds uri ver updatedDiags where updatedDiags = Map.singleton (Just stage) (SL.toSortedList diags) getAllDiagnostics :: - DiagnosticStore -> - [FileDiagnostic] + STMDiagnosticStore -> + STM [FileDiagnostic] getAllDiagnostics = - concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . HMap.toList - -getUriDiagnostics :: - NormalizedUri -> - DiagnosticStore -> - [LSP.Diagnostic] -getUriDiagnostics uri ds = - maybe [] getDiagnosticsFromStore $ - HMap.lookup uri ds + fmap (concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v)) . ListT.toList . STM.listT -updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO () -updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do - modifyVar_ positionMapping $ \allMappings -> do - let uri = toNormalizedUri _uri - let mappingForUri = HMap.lookupDefault Map.empty uri allMappings - let (_, updatedMapping) = +updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> STM () +updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = + STM.focus (Focus.alter f) uri positionMapping + where + uri = toNormalizedUri _uri + f = Just . f' . fromMaybe mempty + f' mappingForUri = snd $ -- Very important to use mapAccum here so that the tails of -- each mapping can be shared, otherwise quadratic space is -- used which is evident in long running sessions. Map.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc))) zeroMapping (Map.insert _version (shared_change, zeroMapping) mappingForUri) - pure $ HMap.insert uri updatedMapping allMappings - where - shared_change = mkDelta changes + shared_change = mkDelta changes diff --git a/src/Development/IDE/Core/Tracing.hs b/src/Development/IDE/Core/Tracing.hs --- a/src/Development/IDE/Core/Tracing.hs +++ b/src/Development/IDE/Core/Tracing.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE NoApplicativeDo #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PatternSynonyms #-} {-# HLINT ignore #-} module Development.IDE.Core.Tracing ( otTracedHandler @@ -16,62 +17,65 @@ ) where -import Control.Concurrent.Async (Async, async) -import Control.Concurrent.Extra (Var, modifyVar_, newVar, - readVar, threadDelay) -import Control.Exception (evaluate) -import Control.Exception.Safe (SomeException, catch, - generalBracket) -import Control.Monad (forM_, forever, void, when, - (>=>)) -import Control.Monad.Catch (ExitCase (..), MonadMask) -import Control.Monad.Extra (whenJust) +import Control.Concurrent.Async (Async, async) +import Control.Concurrent.Extra (modifyVar_, newVar, readVar, + threadDelay) +import Control.Exception (evaluate) +import Control.Exception.Safe (SomeException, catch, + generalBracket) +import Control.Monad (forM_, forever, void, when, + (>=>)) +import Control.Monad.Catch (ExitCase (..), MonadMask) +import Control.Monad.Extra (whenJust) import Control.Monad.IO.Unlift -import Control.Seq (r0, seqList, seqTuple2, using) -import Data.ByteString (ByteString) -import Data.ByteString.Char8 (pack) -import Data.Dynamic (Dynamic) -import qualified Data.HashMap.Strict as HMap -import Data.IORef (modifyIORef', newIORef, - readIORef, writeIORef) -import Data.String (IsString (fromString)) -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) -import Data.Typeable (TypeRep, typeOf) -import Data.Word (Word16) -import Debug.Trace.Flags (userTracingEnabled) -import Development.IDE.Core.RuleTypes (GhcSession (GhcSession), - GhcSessionDeps (GhcSessionDeps), - GhcSessionIO (GhcSessionIO)) -import Development.IDE.Graph (Action) +import Control.Monad.STM (atomically) +import Control.Seq (r0, seqList, seqTuple2, + using) +import Data.ByteString (ByteString) +import Data.ByteString.Char8 (pack) +import qualified Data.HashMap.Strict as HMap +import Data.IORef (modifyIORef', newIORef, + readIORef, writeIORef) +import Data.String (IsString (fromString)) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Typeable (TypeRep, typeOf) +import Data.Word (Word16) +import Debug.Trace.Flags (userTracingEnabled) +import Development.IDE.Core.RuleTypes (GhcSession (GhcSession), + GhcSessionDeps (GhcSessionDeps), + GhcSessionIO (GhcSessionIO)) +import Development.IDE.Graph (Action) import Development.IDE.Graph.Rule -import Development.IDE.Types.Diagnostics (FileDiagnostic, showDiagnostics) -import Development.IDE.Types.Location (Uri (..)) -import Development.IDE.Types.Logger (Logger (Logger), logDebug, - logInfo) -import Development.IDE.Types.Shake (Value, - ValueWithDiagnostics (..), - Values, fromKeyType) -import Foreign.Storable (Storable (sizeOf)) -import HeapSize (recursiveSize, runHeapsize) -import Ide.PluginUtils (installSigUsr1Handler) -import Ide.Types (PluginId (..)) -import Language.LSP.Types (NormalizedFilePath, - fromNormalizedFilePath) -import Numeric.Natural (Natural) -import OpenTelemetry.Eventlog (SpanInFlight (..), addEvent, - beginSpan, endSpan, - mkValueObserver, observe, - setTag, withSpan, withSpan_) +import Development.IDE.Types.Diagnostics (FileDiagnostic, + showDiagnostics) +import Development.IDE.Types.Location (Uri (..)) +import Development.IDE.Types.Logger (Logger (Logger), logDebug, + logInfo) +import Development.IDE.Types.Shake (ValueWithDiagnostics (..), + Values, fromKeyType) +import Foreign.Storable (Storable (sizeOf)) +import HeapSize (recursiveSize, runHeapsize) +import Ide.PluginUtils (installSigUsr1Handler) +import Ide.Types (PluginId (..)) +import Language.LSP.Types (NormalizedFilePath, + fromNormalizedFilePath) +import qualified "list-t" ListT +import Numeric.Natural (Natural) +import OpenTelemetry.Eventlog (SpanInFlight (..), addEvent, + beginSpan, endSpan, + mkValueObserver, observe, + setTag, withSpan, withSpan_) +import qualified StmContainers.Map as STM #if MIN_VERSION_ghc(8,8,0) otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => ByteString -> f [a] -> f [a] -withEventTrace :: (MonadMask m, MonadIO m) => String -> ((ByteString -> ByteString -> m ()) -> m a) -> m a +withEventTrace :: (MonadMask m, MonadIO m) => String -> ((ByteString -> m ()) -> m a) -> m a #else otTracedProvider :: MonadUnliftIO m => PluginId -> String -> m a -> m a otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => String -> f [a] -> f [a] -withEventTrace :: (MonadMask m, MonadIO m) => String -> ((String -> ByteString -> m ()) -> m a) -> m a +withEventTrace :: (MonadMask m, MonadIO m) => String -> ((ByteString -> m ()) -> m a) -> m a #endif withTrace :: (MonadMask m, MonadIO m) => @@ -86,8 +90,8 @@ withEventTrace name act | userTracingEnabled = withSpan (fromString name) $ \sp -> do - act (addEvent sp) - | otherwise = act (\_ _ -> pure ()) + act (addEvent sp "") + | otherwise = act (\_ -> pure ()) -- | Returns a logger that produces telemetry events in a single span withTelemetryLogger :: (MonadIO m, MonadMask m) => (Logger -> m a) -> m a @@ -174,16 +178,16 @@ | otherwise = act -startProfilingTelemetry :: Bool -> Logger -> Var Values -> IO () -startProfilingTelemetry allTheTime logger stateRef = do +startProfilingTelemetry :: Bool -> Logger -> Values -> IO () +startProfilingTelemetry allTheTime logger state = do instrumentFor <- getInstrumentCached installSigUsr1Handler $ do logInfo logger "SIGUSR1 received: performing memory measurement" - performMeasurement logger stateRef instrumentFor + performMeasurement logger state instrumentFor when allTheTime $ void $ regularly (1 * seconds) $ - performMeasurement logger stateRef instrumentFor + performMeasurement logger state instrumentFor where seconds = 1000000 @@ -193,17 +197,16 @@ performMeasurement :: Logger -> - Var Values -> + Values -> (Maybe String -> IO OurValueObserver) -> IO () -performMeasurement logger stateRef instrumentFor = do - - values <- readVar stateRef +performMeasurement logger values instrumentFor = do + contents <- atomically $ ListT.toList $ STM.listT values let keys = typeOf GhcSession : typeOf GhcSessionDeps -- TODO restore : [ kty - | k <- HMap.keys values + | (k,_) <- contents , Just (kty,_) <- [fromKeyType k] -- do GhcSessionIO last since it closes over stateRef itself , kty /= typeOf GhcSession @@ -212,7 +215,7 @@ ] ++ [typeOf GhcSessionIO] groupedForSharing <- evaluate (keys `using` seqList r0) - measureMemory logger [groupedForSharing] instrumentFor stateRef + measureMemory logger [groupedForSharing] instrumentFor values `catch` \(e::SomeException) -> logInfo logger ("MEMORY PROFILING ERROR: " <> fromString (show e)) @@ -243,12 +246,12 @@ :: Logger -> [[TypeRep]] -- ^ Grouping of keys for the sharing-aware analysis -> (Maybe String -> IO OurValueObserver) - -> Var Values + -> Values -> IO () -measureMemory logger groups instrumentFor stateRef = withSpan_ "Measure Memory" $ do - values <- readVar stateRef +measureMemory logger groups instrumentFor values = withSpan_ "Measure Memory" $ do + contents <- atomically $ ListT.toList $ STM.listT values valuesSizeRef <- newIORef $ Just 0 - let !groupsOfGroupedValues = groupValues values + let !groupsOfGroupedValues = groupValues contents logDebug logger "STARTING MEMORY PROFILING" forM_ groupsOfGroupedValues $ \groupedValues -> do keepGoing <- readIORef valuesSizeRef @@ -277,12 +280,12 @@ logInfo logger "Memory profiling could not be completed: increase the size of your nursery (+RTS -Ax) and try again" where - groupValues :: Values -> [ [(String, [Value Dynamic])] ] - groupValues values = + -- groupValues :: Values -> [ [(String, [Value Dynamic])] ] + groupValues contents = let !groupedValues = [ [ (show ty, vv) | ty <- groupKeys - , let vv = [ v | (fromKeyType -> Just (kty,_), ValueWithDiagnostics v _) <- HMap.toList values + , let vv = [ v | (fromKeyType -> Just (kty,_), ValueWithDiagnostics v _) <- contents , kty == ty] ] | groupKeys <- groups diff --git a/src/Development/IDE/Core/UseStale.hs b/src/Development/IDE/Core/UseStale.hs --- a/src/Development/IDE/Core/UseStale.hs +++ b/src/Development/IDE/Core/UseStale.hs @@ -1,163 +1,162 @@ -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} - -module Development.IDE.Core.UseStale - ( Age(..) - , Tracked - , unTrack - , PositionMap - , TrackedStale (..) - , untrackedStaleValue - , unsafeMkStale - , unsafeMkCurrent - , unsafeCopyAge - , MapAge (..) - , dualPositionMap - , useWithStale - , useWithStale_ - ) where - -import Control.Arrow -import Control.Category (Category) -import qualified Control.Category as C -import Control.DeepSeq (NFData) -import Data.Aeson -import Data.Coerce (coerce) -import Data.Functor ((<&>)) -import Data.Functor.Identity (Identity (Identity)) -import Data.Kind (Type) -import Data.String (fromString) -import Development.IDE.GHC.Compat (RealSrcSpan, - srcSpanFile) -import Development.IDE.GHC.Compat.Util (unpackFS) -import Development.IDE (Action, IdeRule, - NormalizedFilePath, - Range, - rangeToRealSrcSpan, - realSrcSpanToRange) -import qualified Development.IDE.Core.PositionMapping as P -import qualified Development.IDE.Core.Shake as IDE - - ------------------------------------------------------------------------------- --- | A data kind for 'Tracked'. -data Age = Current | Stale Type - - ------------------------------------------------------------------------------- --- | Some value, tagged with its age. All 'Current' ages are considered to be --- the same thing, but 'Stale' values are protected by an untouchable variable --- to ensure they can't be unified. -newtype Tracked (age :: Age) a = UnsafeTracked - { unTrack :: a - } - deriving stock (Functor, Foldable, Traversable) - deriving newtype (Eq, Ord, Show, Read, ToJSON, FromJSON, NFData) - deriving (Applicative, Monad) via Identity - - ------------------------------------------------------------------------------- --- | Like 'P.PositionMapping', but with annotated ages for how 'Tracked' values --- change. Use the 'Category' instance to compose 'PositionMapping's in order --- to transform between values of different stale ages. -newtype PositionMap (from :: Age) (to :: Age) = PositionMap - { _getPositionMapping :: P.PositionMapping - } - -instance Category PositionMap where - id = coerce P.zeroMapping - (.) = coerce P.composeDelta - - ------------------------------------------------------------------------------- --- | Get a 'PositionMap' that runs in the opposite direction. -dualPositionMap :: PositionMap from to -> PositionMap to from -dualPositionMap (PositionMap (P.PositionMapping (P.PositionDelta from to))) = - PositionMap $ P.PositionMapping $ P.PositionDelta to from - - ------------------------------------------------------------------------------- --- | A pair containing a @'Tracked' 'Stale'@ value, as well as --- a 'PositionMapping' that will fast-forward values to the current age. -data TrackedStale a where - TrackedStale - :: Tracked (Stale s) a - -> PositionMap (Stale s) Current - -> TrackedStale a - -instance Functor TrackedStale where - fmap f (TrackedStale t pm) = TrackedStale (fmap f t) pm - - -untrackedStaleValue :: TrackedStale a -> a -untrackedStaleValue (TrackedStale ta _) = coerce ta - - ------------------------------------------------------------------------------- --- | A class for which 'Tracked' values can be run across a 'PositionMapping' --- to change their ages. -class MapAge a where - {-# MINIMAL mapAgeFrom | mapAgeTo #-} - mapAgeFrom :: PositionMap from to -> Tracked to a -> Maybe (Tracked from a) - mapAgeFrom = mapAgeTo . dualPositionMap - - mapAgeTo :: PositionMap from to -> Tracked from a -> Maybe (Tracked to a) - mapAgeTo = mapAgeFrom . dualPositionMap - - -instance MapAge Range where - mapAgeFrom = coerce P.fromCurrentRange - mapAgeTo = coerce P.toCurrentRange - - -instance MapAge RealSrcSpan where - mapAgeFrom = - invMapAge (\fs -> rangeToRealSrcSpan (fromString $ unpackFS fs)) - (srcSpanFile &&& realSrcSpanToRange) - . mapAgeFrom - - ------------------------------------------------------------------------------- --- | Helper function for deriving 'MapAge' for values in terms of other --- instances. -invMapAge - :: (c -> a -> b) - -> (b -> (c, a)) - -> (Tracked from a -> Maybe (Tracked to a)) - -> Tracked from b - -> Maybe (Tracked to b) -invMapAge to from f t = - let (c, t') = unTrack $ fmap from t - in fmap (fmap $ to c) $ f $ UnsafeTracked t' - - -unsafeMkCurrent :: age -> Tracked 'Current age -unsafeMkCurrent = coerce - - -unsafeMkStale :: age -> Tracked (Stale s) age -unsafeMkStale = coerce - - -unsafeCopyAge :: Tracked age a -> b -> Tracked age b -unsafeCopyAge _ = coerce - - --- | Request a Rule result, it not available return the last computed result, if any, which may be stale -useWithStale :: IdeRule k v - => k -> NormalizedFilePath -> Action (Maybe (TrackedStale v)) -useWithStale key file = do - x <- IDE.useWithStale key file - pure $ x <&> \(v, pm) -> - TrackedStale (coerce v) (coerce pm) - --- | Request a Rule result, it not available return the last computed result which may be stale. --- Errors out if none available. -useWithStale_ :: IdeRule k v - => k -> NormalizedFilePath -> Action (TrackedStale v) -useWithStale_ key file = do - (v, pm) <- IDE.useWithStale_ key file - pure $ TrackedStale (coerce v) (coerce pm) - +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} + +module Development.IDE.Core.UseStale + ( Age(..) + , Tracked + , unTrack + , PositionMap + , TrackedStale (..) + , untrackedStaleValue + , unsafeMkStale + , unsafeMkCurrent + , unsafeCopyAge + , MapAge (..) + , dualPositionMap + , useWithStale + , useWithStale_ + ) where + +import Control.Arrow +import Control.Category (Category) +import qualified Control.Category as C +import Control.DeepSeq (NFData) +import Data.Aeson +import Data.Coerce (coerce) +import Data.Functor ((<&>)) +import Data.Functor.Identity (Identity (Identity)) +import Data.Kind (Type) +import Data.String (fromString) +import Development.IDE (Action, IdeRule, + NormalizedFilePath, + Range, + rangeToRealSrcSpan, + realSrcSpanToRange) +import qualified Development.IDE.Core.PositionMapping as P +import qualified Development.IDE.Core.Shake as IDE +import Development.IDE.GHC.Compat (RealSrcSpan, srcSpanFile) +import Development.IDE.GHC.Compat.Util (unpackFS) + + +------------------------------------------------------------------------------ +-- | A data kind for 'Tracked'. +data Age = Current | Stale Type + + +------------------------------------------------------------------------------ +-- | Some value, tagged with its age. All 'Current' ages are considered to be +-- the same thing, but 'Stale' values are protected by an untouchable variable +-- to ensure they can't be unified. +newtype Tracked (age :: Age) a = UnsafeTracked + { unTrack :: a + } + deriving stock (Functor, Foldable, Traversable) + deriving newtype (Eq, Ord, Show, Read, ToJSON, FromJSON, NFData) + deriving (Applicative, Monad) via Identity + + +------------------------------------------------------------------------------ +-- | Like 'P.PositionMapping', but with annotated ages for how 'Tracked' values +-- change. Use the 'Category' instance to compose 'PositionMapping's in order +-- to transform between values of different stale ages. +newtype PositionMap (from :: Age) (to :: Age) = PositionMap + { _getPositionMapping :: P.PositionMapping + } + +instance Category PositionMap where + id = coerce P.zeroMapping + (.) = coerce P.composeDelta + + +------------------------------------------------------------------------------ +-- | Get a 'PositionMap' that runs in the opposite direction. +dualPositionMap :: PositionMap from to -> PositionMap to from +dualPositionMap (PositionMap (P.PositionMapping (P.PositionDelta from to))) = + PositionMap $ P.PositionMapping $ P.PositionDelta to from + + +------------------------------------------------------------------------------ +-- | A pair containing a @'Tracked' 'Stale'@ value, as well as +-- a 'PositionMapping' that will fast-forward values to the current age. +data TrackedStale a where + TrackedStale + :: Tracked (Stale s) a + -> PositionMap (Stale s) Current + -> TrackedStale a + +instance Functor TrackedStale where + fmap f (TrackedStale t pm) = TrackedStale (fmap f t) pm + + +untrackedStaleValue :: TrackedStale a -> a +untrackedStaleValue (TrackedStale ta _) = coerce ta + + +------------------------------------------------------------------------------ +-- | A class for which 'Tracked' values can be run across a 'PositionMapping' +-- to change their ages. +class MapAge a where + {-# MINIMAL mapAgeFrom | mapAgeTo #-} + mapAgeFrom :: PositionMap from to -> Tracked to a -> Maybe (Tracked from a) + mapAgeFrom = mapAgeTo . dualPositionMap + + mapAgeTo :: PositionMap from to -> Tracked from a -> Maybe (Tracked to a) + mapAgeTo = mapAgeFrom . dualPositionMap + + +instance MapAge Range where + mapAgeFrom = coerce P.fromCurrentRange + mapAgeTo = coerce P.toCurrentRange + + +instance MapAge RealSrcSpan where + mapAgeFrom = + invMapAge (\fs -> rangeToRealSrcSpan (fromString $ unpackFS fs)) + (srcSpanFile &&& realSrcSpanToRange) + . mapAgeFrom + + +------------------------------------------------------------------------------ +-- | Helper function for deriving 'MapAge' for values in terms of other +-- instances. +invMapAge + :: (c -> a -> b) + -> (b -> (c, a)) + -> (Tracked from a -> Maybe (Tracked to a)) + -> Tracked from b + -> Maybe (Tracked to b) +invMapAge to from f t = + let (c, t') = unTrack $ fmap from t + in fmap (fmap $ to c) $ f $ UnsafeTracked t' + + +unsafeMkCurrent :: age -> Tracked 'Current age +unsafeMkCurrent = coerce + + +unsafeMkStale :: age -> Tracked (Stale s) age +unsafeMkStale = coerce + + +unsafeCopyAge :: Tracked age a -> b -> Tracked age b +unsafeCopyAge _ = coerce + + +-- | Request a Rule result, it not available return the last computed result, if any, which may be stale +useWithStale :: IdeRule k v + => k -> NormalizedFilePath -> Action (Maybe (TrackedStale v)) +useWithStale key file = do + x <- IDE.useWithStale key file + pure $ x <&> \(v, pm) -> + TrackedStale (coerce v) (coerce pm) + +-- | Request a Rule result, it not available return the last computed result which may be stale. +-- Errors out if none available. +useWithStale_ :: IdeRule k v + => k -> NormalizedFilePath -> Action (TrackedStale v) +useWithStale_ key file = do + (v, pm) <- IDE.useWithStale_ key file + pure $ TrackedStale (coerce v) (coerce pm) + diff --git a/src/Development/IDE/GHC/CPP.hs b/src/Development/IDE/GHC/CPP.hs --- a/src/Development/IDE/GHC/CPP.hs +++ b/src/Development/IDE/GHC/CPP.hs @@ -1,63 +1,63 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE CPP #-} -{-# LANGUAGE NondecreasingIndentation #-} - ------------------------------------------------------------------------------ --- --- GHC Driver --- --- (c) The University of Glasgow 2005 --- ------------------------------------------------------------------------------ - -module Development.IDE.GHC.CPP(doCpp, addOptP) -where - -import GHC -import Development.IDE.GHC.Compat as Compat -#if !MIN_VERSION_ghc(8,10,0) -import qualified Development.IDE.GHC.Compat.CPP as CPP -#else -import Development.IDE.GHC.Compat.Util -#endif - -#if MIN_VERSION_ghc(9,0,0) -import qualified GHC.Driver.Pipeline as Pipeline -import GHC.Settings -#else -#if MIN_VERSION_ghc (8,10,0) -import qualified DriverPipeline as Pipeline -import ToolSettings -#else -import DynFlags -#endif -#endif - -addOptP :: String -> DynFlags -> DynFlags -#if MIN_VERSION_ghc (8,10,0) -addOptP f = alterToolSettings $ \s -> s - { toolSettings_opt_P = f : toolSettings_opt_P s - , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s) - } - where - fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss - alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) } -#else -addOptP opt = onSettings (onOptP (opt:)) - where - onSettings f x = x{settings = f $ settings x} - onOptP f x = x{sOpt_P = f $ sOpt_P x} -#endif - -doCpp :: HscEnv -> Bool -> FilePath -> FilePath -> IO () -doCpp env raw input_fn output_fn = -#if MIN_VERSION_ghc (9,2,0) - Pipeline.doCpp (hsc_logger env) (hsc_tmpfs env) (hsc_dflags env) (hsc_unit_env env) raw input_fn output_fn -#elif MIN_VERSION_ghc (8,10,0) - Pipeline.doCpp (hsc_dflags env) raw input_fn output_fn -#else - CPP.doCpp (hsc_dflags env) raw input_fn output_fn -#endif - +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE CPP #-} +{-# LANGUAGE NondecreasingIndentation #-} + +----------------------------------------------------------------------------- +-- +-- GHC Driver +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module Development.IDE.GHC.CPP(doCpp, addOptP) +where + +import Development.IDE.GHC.Compat as Compat +import GHC +#if !MIN_VERSION_ghc(8,10,0) +import qualified Development.IDE.GHC.Compat.CPP as CPP +#else +import Development.IDE.GHC.Compat.Util +#endif + +#if MIN_VERSION_ghc(9,0,0) +import qualified GHC.Driver.Pipeline as Pipeline +import GHC.Settings +#else +#if MIN_VERSION_ghc (8,10,0) +import qualified DriverPipeline as Pipeline +import ToolSettings +#else +import DynFlags +#endif +#endif + +addOptP :: String -> DynFlags -> DynFlags +#if MIN_VERSION_ghc (8,10,0) +addOptP f = alterToolSettings $ \s -> s + { toolSettings_opt_P = f : toolSettings_opt_P s + , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s) + } + where + fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss + alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) } +#else +addOptP opt = onSettings (onOptP (opt:)) + where + onSettings f x = x{settings = f $ settings x} + onOptP f x = x{sOpt_P = f $ sOpt_P x} +#endif + +doCpp :: HscEnv -> Bool -> FilePath -> FilePath -> IO () +doCpp env raw input_fn output_fn = +#if MIN_VERSION_ghc (9,2,0) + Pipeline.doCpp (hsc_logger env) (hsc_tmpfs env) (hsc_dflags env) (hsc_unit_env env) raw input_fn output_fn +#elif MIN_VERSION_ghc (8,10,0) + Pipeline.doCpp (hsc_dflags env) raw input_fn output_fn +#else + CPP.doCpp (hsc_dflags env) raw input_fn output_fn +#endif + diff --git a/src/Development/IDE/GHC/Compat.hs b/src/Development/IDE/GHC/Compat.hs --- a/src/Development/IDE/GHC/Compat.hs +++ b/src/Development/IDE/GHC/Compat.hs @@ -4,6 +4,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} {-# OPTIONS -Wno-incomplete-uni-patterns -Wno-dodgy-imports #-} -- | Attempt at hiding the GHC version differences we can. @@ -15,13 +16,26 @@ setUpTypedHoles, upNameCache, disableWarningsAsErrors, + reLoc, + reLocA, + getMessages', + pattern PFailedWithErrorMessages, #if !MIN_VERSION_ghc(9,0,1) RefMap, #endif +#if MIN_VERSION_ghc(9,2,0) + extendModSummaryNoDeps, + emsModSummary, +#endif + nodeInfo', getNodeIds, + nodeInfoFromSource, + isAnnotationInNodeInfo, + mkAstNode, + combineRealSrcSpans, isQualifiedImport, GhcVersion(..), @@ -43,6 +57,7 @@ -- * Compat modules module Development.IDE.GHC.Compat.Core, module Development.IDE.GHC.Compat.Env, + module Development.IDE.GHC.Compat.ExactPrint, module Development.IDE.GHC.Compat.Iface, module Development.IDE.GHC.Compat.Logger, module Development.IDE.GHC.Compat.Outputable, @@ -56,65 +71,85 @@ runPp, ) where -import GHC hiding (HasSrcSpan, ModLocation, getLoc, - lookupName, RealSrcSpan) -import Development.IDE.GHC.Compat.Core -import Development.IDE.GHC.Compat.Env -import Development.IDE.GHC.Compat.Iface -import Development.IDE.GHC.Compat.Logger -import Development.IDE.GHC.Compat.Outputable -import Development.IDE.GHC.Compat.Parser -import Development.IDE.GHC.Compat.Plugins -import Development.IDE.GHC.Compat.Units -import Development.IDE.GHC.Compat.Util +import Development.IDE.GHC.Compat.Core +import Development.IDE.GHC.Compat.Env +import Development.IDE.GHC.Compat.ExactPrint +import Development.IDE.GHC.Compat.Iface +import Development.IDE.GHC.Compat.Logger +import Development.IDE.GHC.Compat.Outputable +import Development.IDE.GHC.Compat.Parser +import Development.IDE.GHC.Compat.Plugins +import Development.IDE.GHC.Compat.Units +import Development.IDE.GHC.Compat.Util +import GHC hiding (HasSrcSpan, + ModLocation, + RealSrcSpan, getLoc, + lookupName) #if MIN_VERSION_ghc(9,0,0) import GHC.Data.StringBuffer -import GHC.Driver.Session hiding (ExposePackage) +import GHC.Driver.Session hiding (ExposePackage) +import qualified GHC.Types.SrcLoc as SrcLoc +import GHC.Utils.Error #if MIN_VERSION_ghc(9,2,0) -import GHC.Driver.Env as Env +import Data.Bifunctor +import GHC.Driver.Env as Env import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModSummary #else import GHC.Driver.Types #endif import GHC.Iface.Env -import GHC.Iface.Make (mkIfaceExports) -import qualified GHC.SysTools.Tasks as SysTools -import qualified GHC.Types.Avail as Avail +import GHC.Iface.Make (mkIfaceExports) +import qualified GHC.SysTools.Tasks as SysTools +import qualified GHC.Types.Avail as Avail #else -import DynFlags hiding (ExposePackage) -import HscTypes -import MkIface hiding (writeIfaceFile) import qualified Avail +import DynFlags hiding (ExposePackage) +import HscTypes +import MkIface hiding (writeIfaceFile) #if MIN_VERSION_ghc(8,8,0) -import StringBuffer (hPutStringBuffer) +import StringBuffer (hPutStringBuffer) #endif import qualified SysTools #if !MIN_VERSION_ghc(8,8,0) -import SrcLoc (RealLocated) import qualified EnumSet +import SrcLoc (RealLocated) import Foreign.ForeignPtr import System.IO #endif #endif -import Compat.HieAst (enrichHie) +import Compat.HieAst (enrichHie) import Compat.HieBin import Compat.HieTypes import Compat.HieUtils -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS import Data.IORef -import qualified Data.Map as Map -import Data.List (foldl') +import Data.List (foldl') +import qualified Data.Map as Map +import qualified Data.Set as Set #if MIN_VERSION_ghc(9,0,0) -import qualified Data.Set as S +import qualified Data.Set as S #endif +#if !MIN_VERSION_ghc(8,10,0) +import Bag (unitBag) +#endif + +#if !MIN_VERSION_ghc(9,2,0) +reLoc :: Located a -> Located a +reLoc = id + +reLocA :: Located a -> Located a +reLocA = id +#endif + #if !MIN_VERSION_ghc(8,8,0) hPutStringBuffer :: Handle -> StringBuffer -> IO () hPutStringBuffer hdl (StringBuffer buf len cur) @@ -122,12 +157,45 @@ hPutBuf hdl ptr len #endif +#if MIN_VERSION_ghc(9,2,0) +type ErrMsg = MsgEnvelope DecoratedSDoc +#endif + +getMessages' :: PState -> DynFlags -> (Bag WarnMsg, Bag ErrMsg) +getMessages' pst dflags = +#if MIN_VERSION_ghc(9,2,0) + bimap (fmap pprWarning) (fmap pprError) $ +#endif + getMessages pst +#if !MIN_VERSION_ghc(9,2,0) + dflags +#endif + +#if MIN_VERSION_ghc(9,2,0) +pattern PFailedWithErrorMessages :: forall a b. (b -> Bag (MsgEnvelope DecoratedSDoc)) -> ParseResult a +pattern PFailedWithErrorMessages msgs + <- PFailed (const . fmap pprError . getErrorMessages -> msgs) +#elif MIN_VERSION_ghc(8,10,0) +pattern PFailedWithErrorMessages :: (DynFlags -> ErrorMessages) -> ParseResult a +pattern PFailedWithErrorMessages msgs + <- PFailed (getErrorMessages -> msgs) +#else +pattern PFailedWithErrorMessages :: (DynFlags -> ErrorMessages) -> ParseResult a +pattern PFailedWithErrorMessages msgs + <- ((fmap.fmap) unitBag . mkPlainErrMsgIfPFailed -> Just msgs) + +mkPlainErrMsgIfPFailed (PFailed _ pst err) = Just (\dflags -> mkPlainErrMsg dflags pst err) +mkPlainErrMsgIfPFailed _ = Nothing +#endif +{-# COMPLETE PFailedWithErrorMessages #-} + supportsHieFiles :: Bool supportsHieFiles = True hieExportNames :: HieFile -> [(SrcSpan, Name)] hieExportNames = nameListFromAvails . hie_exports + upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c #if MIN_VERSION_ghc(8,8,0) upNameCache = updNameCache @@ -274,6 +342,13 @@ -- unhelpfulSpanFS = id #endif +nodeInfoFromSource :: HieAST a -> Maybe (NodeInfo a) +#if MIN_VERSION_ghc(9,0,0) +nodeInfoFromSource = Map.lookup SourceInfo . getSourcedNodeInfo . sourcedNodeInfo +#else +nodeInfoFromSource = Just . nodeInfo +#endif + data GhcVersion = GHC86 | GHC88 @@ -312,4 +387,32 @@ SysTools.runPp #else const SysTools.runPp +#endif + +isAnnotationInNodeInfo :: (FastString, FastString) -> NodeInfo a -> Bool +#if MIN_VERSION_ghc(9,2,0) +isAnnotationInNodeInfo (ctor, typ) = Set.member (NodeAnnotation ctor typ) . nodeAnnotations +#else +isAnnotationInNodeInfo p = Set.member p . nodeAnnotations +#endif + +mkAstNode :: NodeInfo a -> Span -> [HieAST a] -> HieAST a +#if MIN_VERSION_ghc(9,0,0) +mkAstNode n = Node (SourcedNodeInfo $ Map.singleton GeneratedInfo n) +#else +mkAstNode = Node +#endif + +combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan +#if MIN_VERSION_ghc(9,2,0) +combineRealSrcSpans = SrcLoc.combineRealSrcSpans +#else +combineRealSrcSpans span1 span2 + = mkRealSrcSpan (mkRealSrcLoc file line_start col_start) (mkRealSrcLoc file line_end col_end) + where + (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1) + (srcSpanStartLine span2, srcSpanStartCol span2) + (line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1) + (srcSpanEndLine span2, srcSpanEndCol span2) + file = srcSpanFile span1 #endif diff --git a/src/Development/IDE/GHC/Compat/CPP.hs b/src/Development/IDE/GHC/Compat/CPP.hs --- a/src/Development/IDE/GHC/Compat/CPP.hs +++ b/src/Development/IDE/GHC/Compat/CPP.hs @@ -1,204 +1,204 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - --- Copied from https://github.com/ghc/ghc/blob/master/compiler/main/DriverPipeline.hs on 14 May 2019 --- Requested to be exposed at https://gitlab.haskell.org/ghc/ghc/merge_requests/944. --- Update the above MR got merged to master on 31 May 2019. When it becomes avialable to ghc-lib, this file can be removed. - -{- HLINT ignore -} -- since copied from upstream - -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} --- | Re-export 'doCpp' for GHC < 8.10. --- --- Later versions export what we need. -module Development.IDE.GHC.Compat.CPP ( - doCpp - ) where - -import FileCleanup -import Packages -import Panic -import SysTools -#if MIN_VERSION_ghc(8,8,2) -import LlvmCodeGen (llvmVersionList) -#elif MIN_VERSION_ghc(8,8,0) -import LlvmCodeGen (LlvmVersion (..)) -#endif -import DynFlags -import Module (toInstalledUnitId, rtsUnitId) -import Control.Monad -import Data.List (intercalate) -import Data.Maybe -import Data.Version -import System.Directory -import System.FilePath -import System.Info - -import Development.IDE.GHC.Compat as Compat - -doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO () -doCpp dflags raw input_fn output_fn = do - let hscpp_opts = picPOpts dflags - let cmdline_include_paths = includePaths dflags - - pkg_include_dirs <- getPackageIncludePath dflags [] - let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] - (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) - let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] - (includePathsQuote cmdline_include_paths) - let include_paths = include_paths_quote ++ include_paths_global - - let verbFlags = getVerbFlags dflags - - let cpp_prog args | raw = SysTools.runCpp dflags args -#if MIN_VERSION_ghc(8,10,0) - | otherwise = SysTools.runCc Nothing -#else - | otherwise = SysTools.runCc -#endif - dflags (SysTools.Option "-E" : args) - - let target_defs = - -- NEIL: Patched to use System.Info instead of constants from CPP - [ "-D" ++ os ++ "_BUILD_OS", - "-D" ++ arch ++ "_BUILD_ARCH", - "-D" ++ os ++ "_HOST_OS", - "-D" ++ arch ++ "_HOST_ARCH" ] - -- remember, in code we *compile*, the HOST is the same our TARGET, - -- and BUILD is the same as our HOST. - - let sse_defs = - [ "-D__SSE__" | isSseEnabled dflags ] ++ - [ "-D__SSE2__" | isSse2Enabled dflags ] ++ - [ "-D__SSE4_2__" | isSse4_2Enabled dflags ] - - let avx_defs = - [ "-D__AVX__" | isAvxEnabled dflags ] ++ - [ "-D__AVX2__" | isAvx2Enabled dflags ] ++ - [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++ - [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++ - [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++ - [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ] - - backend_defs <- getBackendDefs dflags - - let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ] - -- Default CPP defines in Haskell source - ghcVersionH <- getGhcVersionPathName dflags - let hsSourceCppOpts = [ "-include", ghcVersionH ] - - -- MIN_VERSION macros - let uids = explicitPackages (pkgState dflags) - pkgs = catMaybes (map (lookupPackage dflags) uids) - mb_macro_include <- - if not (null pkgs) && gopt Opt_VersionMacros dflags - then do macro_stub <- newTempName dflags TFL_CurrentModule "h" - writeFile macro_stub (generatePackageVersionMacros pkgs) - -- Include version macros for every *exposed* package. - -- Without -hide-all-packages and with a package database - -- size of 1000 packages, it takes cpp an estimated 2 - -- milliseconds to process this file. See #10970 - -- comment 8. - return [SysTools.FileOption "-include" macro_stub] - else return [] - - cpp_prog ( map SysTools.Option verbFlags - ++ map SysTools.Option include_paths - ++ map SysTools.Option hsSourceCppOpts - ++ map SysTools.Option target_defs - ++ map SysTools.Option backend_defs - ++ map SysTools.Option th_defs - ++ map SysTools.Option hscpp_opts - ++ map SysTools.Option sse_defs - ++ map SysTools.Option avx_defs - ++ mb_macro_include - -- Set the language mode to assembler-with-cpp when preprocessing. This - -- alleviates some of the C99 macro rules relating to whitespace and the hash - -- operator, which we tend to abuse. Clang in particular is not very happy - -- about this. - ++ [ SysTools.Option "-x" - , SysTools.Option "assembler-with-cpp" - , SysTools.Option input_fn - -- We hackily use Option instead of FileOption here, so that the file - -- name is not back-slashed on Windows. cpp is capable of - -- dealing with / in filenames, so it works fine. Furthermore - -- if we put in backslashes, cpp outputs #line directives - -- with *double* backslashes. And that in turn means that - -- our error messages get double backslashes in them. - -- In due course we should arrange that the lexer deals - -- with these \\ escapes properly. - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ]) - -getBackendDefs :: DynFlags -> IO [String] -getBackendDefs dflags | hscTarget dflags == HscLlvm = do - llvmVer <- figureLlvmVersion dflags - return $ case llvmVer of -#if MIN_VERSION_ghc(8,8,2) - Just v - | [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ] - | m:n:_ <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, n) ] -#elif MIN_VERSION_ghc(8,8,0) - Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ] - Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] -#else - Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ] -#endif - _ -> [] - where - format (major, minor) - | minor >= 100 = error "getBackendDefs: Unsupported minor version" - | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int - -getBackendDefs _ = - return [] - --- --------------------------------------------------------------------------- --- Macros (cribbed from Cabal) - -generatePackageVersionMacros :: [Compat.UnitInfo] -> String -generatePackageVersionMacros pkgs = concat - -- Do not add any C-style comments. See #3389. - [ generateMacros "" pkgname version - | pkg <- pkgs - , let version = packageVersion pkg - pkgname = map fixchar (packageNameString pkg) - ] - -fixchar :: Char -> Char -fixchar '-' = '_' -fixchar c = c - -generateMacros :: String -> String -> Version -> String -generateMacros prefix name version = - concat - ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n" - ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n" - ," (major1) < ",major1," || \\\n" - ," (major1) == ",major1," && (major2) < ",major2," || \\\n" - ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" - ,"\n\n" - ] - where - (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) - - --- | Find out path to @ghcversion.h@ file -getGhcVersionPathName :: DynFlags -> IO FilePath -getGhcVersionPathName dflags = do - candidates <- case ghcVersionFile dflags of - Just path -> return [path] - Nothing -> (map ( "ghcversion.h")) <$> - (getPackageIncludePath dflags [toInstalledUnitId rtsUnit]) - - found <- filterM doesFileExist candidates - case found of - [] -> throwGhcExceptionIO (InstallationError - ("ghcversion.h missing; tried: " - ++ intercalate ", " candidates)) - (x:_) -> return x - -rtsUnit :: UnitId -rtsUnit = Module.rtsUnitId +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +-- Copied from https://github.com/ghc/ghc/blob/master/compiler/main/DriverPipeline.hs on 14 May 2019 +-- Requested to be exposed at https://gitlab.haskell.org/ghc/ghc/merge_requests/944. +-- Update the above MR got merged to master on 31 May 2019. When it becomes avialable to ghc-lib, this file can be removed. + +{- HLINT ignore -} -- since copied from upstream + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +-- | Re-export 'doCpp' for GHC < 8.10. +-- +-- Later versions export what we need. +module Development.IDE.GHC.Compat.CPP ( + doCpp + ) where + +import FileCleanup +import Packages +import Panic +import SysTools +#if MIN_VERSION_ghc(8,8,2) +import LlvmCodeGen (llvmVersionList) +#elif MIN_VERSION_ghc(8,8,0) +import LlvmCodeGen (LlvmVersion (..)) +#endif +import Control.Monad +import Data.List (intercalate) +import Data.Maybe +import Data.Version +import DynFlags +import Module (rtsUnitId, toInstalledUnitId) +import System.Directory +import System.FilePath +import System.Info + +import Development.IDE.GHC.Compat as Compat + +doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO () +doCpp dflags raw input_fn output_fn = do + let hscpp_opts = picPOpts dflags + let cmdline_include_paths = includePaths dflags + + pkg_include_dirs <- getPackageIncludePath dflags [] + let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] + (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) + let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] + (includePathsQuote cmdline_include_paths) + let include_paths = include_paths_quote ++ include_paths_global + + let verbFlags = getVerbFlags dflags + + let cpp_prog args | raw = SysTools.runCpp dflags args +#if MIN_VERSION_ghc(8,10,0) + | otherwise = SysTools.runCc Nothing +#else + | otherwise = SysTools.runCc +#endif + dflags (SysTools.Option "-E" : args) + + let target_defs = + -- NEIL: Patched to use System.Info instead of constants from CPP + [ "-D" ++ os ++ "_BUILD_OS", + "-D" ++ arch ++ "_BUILD_ARCH", + "-D" ++ os ++ "_HOST_OS", + "-D" ++ arch ++ "_HOST_ARCH" ] + -- remember, in code we *compile*, the HOST is the same our TARGET, + -- and BUILD is the same as our HOST. + + let sse_defs = + [ "-D__SSE__" | isSseEnabled dflags ] ++ + [ "-D__SSE2__" | isSse2Enabled dflags ] ++ + [ "-D__SSE4_2__" | isSse4_2Enabled dflags ] + + let avx_defs = + [ "-D__AVX__" | isAvxEnabled dflags ] ++ + [ "-D__AVX2__" | isAvx2Enabled dflags ] ++ + [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++ + [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++ + [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++ + [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ] + + backend_defs <- getBackendDefs dflags + + let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ] + -- Default CPP defines in Haskell source + ghcVersionH <- getGhcVersionPathName dflags + let hsSourceCppOpts = [ "-include", ghcVersionH ] + + -- MIN_VERSION macros + let uids = explicitPackages (pkgState dflags) + pkgs = catMaybes (map (lookupPackage dflags) uids) + mb_macro_include <- + if not (null pkgs) && gopt Opt_VersionMacros dflags + then do macro_stub <- newTempName dflags TFL_CurrentModule "h" + writeFile macro_stub (generatePackageVersionMacros pkgs) + -- Include version macros for every *exposed* package. + -- Without -hide-all-packages and with a package database + -- size of 1000 packages, it takes cpp an estimated 2 + -- milliseconds to process this file. See #10970 + -- comment 8. + return [SysTools.FileOption "-include" macro_stub] + else return [] + + cpp_prog ( map SysTools.Option verbFlags + ++ map SysTools.Option include_paths + ++ map SysTools.Option hsSourceCppOpts + ++ map SysTools.Option target_defs + ++ map SysTools.Option backend_defs + ++ map SysTools.Option th_defs + ++ map SysTools.Option hscpp_opts + ++ map SysTools.Option sse_defs + ++ map SysTools.Option avx_defs + ++ mb_macro_include + -- Set the language mode to assembler-with-cpp when preprocessing. This + -- alleviates some of the C99 macro rules relating to whitespace and the hash + -- operator, which we tend to abuse. Clang in particular is not very happy + -- about this. + ++ [ SysTools.Option "-x" + , SysTools.Option "assembler-with-cpp" + , SysTools.Option input_fn + -- We hackily use Option instead of FileOption here, so that the file + -- name is not back-slashed on Windows. cpp is capable of + -- dealing with / in filenames, so it works fine. Furthermore + -- if we put in backslashes, cpp outputs #line directives + -- with *double* backslashes. And that in turn means that + -- our error messages get double backslashes in them. + -- In due course we should arrange that the lexer deals + -- with these \\ escapes properly. + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ]) + +getBackendDefs :: DynFlags -> IO [String] +getBackendDefs dflags | hscTarget dflags == HscLlvm = do + llvmVer <- figureLlvmVersion dflags + return $ case llvmVer of +#if MIN_VERSION_ghc(8,8,2) + Just v + | [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ] + | m:n:_ <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, n) ] +#elif MIN_VERSION_ghc(8,8,0) + Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ] + Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] +#else + Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ] +#endif + _ -> [] + where + format (major, minor) + | minor >= 100 = error "getBackendDefs: Unsupported minor version" + | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int + +getBackendDefs _ = + return [] + +-- --------------------------------------------------------------------------- +-- Macros (cribbed from Cabal) + +generatePackageVersionMacros :: [Compat.UnitInfo] -> String +generatePackageVersionMacros pkgs = concat + -- Do not add any C-style comments. See #3389. + [ generateMacros "" pkgname version + | pkg <- pkgs + , let version = packageVersion pkg + pkgname = map fixchar (packageNameString pkg) + ] + +fixchar :: Char -> Char +fixchar '-' = '_' +fixchar c = c + +generateMacros :: String -> String -> Version -> String +generateMacros prefix name version = + concat + ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n" + ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n" + ," (major1) < ",major1," || \\\n" + ," (major1) == ",major1," && (major2) < ",major2," || \\\n" + ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" + ,"\n\n" + ] + where + (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) + + +-- | Find out path to @ghcversion.h@ file +getGhcVersionPathName :: DynFlags -> IO FilePath +getGhcVersionPathName dflags = do + candidates <- case ghcVersionFile dflags of + Just path -> return [path] + Nothing -> (map ( "ghcversion.h")) <$> + (getPackageIncludePath dflags [toInstalledUnitId rtsUnit]) + + found <- filterM doesFileExist candidates + case found of + [] -> throwGhcExceptionIO (InstallationError + ("ghcversion.h missing; tried: " + ++ intercalate ", " candidates)) + (x:_) -> return x + +rtsUnit :: UnitId +rtsUnit = Module.rtsUnitId diff --git a/src/Development/IDE/GHC/Compat/Core.hs b/src/Development/IDE/GHC/Compat/Core.hs --- a/src/Development/IDE/GHC/Compat/Core.hs +++ b/src/Development/IDE/GHC/Compat/Core.hs @@ -34,6 +34,7 @@ refLevelHoleFits, maxRefHoleFits, maxValidHoleFits, + setOutputFile, #if MIN_VERSION_ghc(8,8,0) CommandLineOption, #if !MIN_VERSION_ghc(9,2,0) @@ -66,7 +67,10 @@ -- slightly unsafe setUnsafeGlobalDynFlags, -- * Linear Haskell +#if !MIN_VERSION_ghc(9,0,0) Scaled, + unrestricted, +#endif scaledThing, -- * Interface Files IfaceExport, @@ -107,6 +111,11 @@ CgGuts(..), -- * ModDetails ModDetails(..), + -- * HsExpr, +#if !MIN_VERSION_ghc(9,2,0) + pattern HsLet, + pattern LetStmt, +#endif -- * Var Type ( TyCoRep.TyVarTy, @@ -121,7 +130,10 @@ TyCoRep.CoercionTy ), pattern FunTy, + pattern ConPatIn, +#if !MIN_VERSION_ghc(9,2,0) Development.IDE.GHC.Compat.Core.splitForAllTyCoVars, +#endif Development.IDE.GHC.Compat.Core.mkVisFunTys, Development.IDE.GHC.Compat.Core.mkInfForAllTys, -- * Specs @@ -147,8 +159,7 @@ -- * TcGblEnv TcGblEnv(..), -- * Parsing and LExer types - HsParsedModule(..), - GHC.ParsedModule(..), + HsModule(..), GHC.ParsedSource, GHC.RenamedSource, -- * Compilation Main @@ -184,6 +195,17 @@ SrcLoc.Located, SrcLoc.unLoc, getLoc, + getLocA, + locA, + noLocA, + LocatedAn, +#if MIN_VERSION_ghc(9,2,0) + GHC.AnnListItem(..), + GHC.NameAnn(..), +#else + AnnListItem, + NameAnn, +#endif SrcLoc.RealLocated, SrcLoc.GenLocated(..), SrcLoc.SrcSpan(SrcLoc.UnhelpfulSpan), @@ -193,6 +215,10 @@ pattern RealSrcLoc, SrcLoc.SrcLoc(SrcLoc.UnhelpfulLoc), BufSpan, +#if MIN_VERSION_ghc(9,2,0) + SrcSpanAnn', + GHC.SrcAnn, +#endif SrcLoc.leftmost_smallest, SrcLoc.containsSpan, SrcLoc.mkGeneralSrcSpan, @@ -202,6 +228,7 @@ SrcLoc.realSrcLocSpan, SrcLoc.realSrcSpanStart, SrcLoc.realSrcSpanEnd, + isSubspanOfA, SrcLoc.isSubspanOf, SrcLoc.wiredInSrcSpan, SrcLoc.mkSrcSpan, @@ -275,6 +302,17 @@ -- * Panic PlainGhcException, panic, + -- * Other + GHC.CoreModule(..), + GHC.SafeHaskellMode(..), + pattern GRE, + gre_name, + gre_imp, + gre_lcl, + gre_par, +#if MIN_VERSION_ghc(9,2,0) + collectHsBindsBinders, +#endif -- * Util Module re-exports #if MIN_VERSION_ghc(9,0,0) module GHC.Builtin.Names, @@ -287,6 +325,7 @@ module GHC.Core.DataCon, module GHC.Core.FamInstEnv, module GHC.Core.InstEnv, + module GHC.Types.Unique.FM, #if !MIN_VERSION_ghc(9,2,0) module GHC.Core.Ppr.TyThing, #endif @@ -306,7 +345,15 @@ module GHC.Iface.Syntax, #if MIN_VERSION_ghc(9,2,0) - module Language.Haskell.Syntax.Expr, + module GHC.Hs.Decls, + module GHC.Hs.Expr, + module GHC.Hs.Doc, + module GHC.Hs.Extension, + module GHC.Hs.ImpExp, + module GHC.Hs.Pat, + module GHC.Hs.Type, + module GHC.Hs.Utils, + module Language.Haskell.Syntax, #endif module GHC.Rename.Names, @@ -328,6 +375,7 @@ module GHC.Types.Name.Env, module GHC.Types.Name.Reader, #if MIN_VERSION_ghc(9,2,0) + module GHC.Types.Avail, module GHC.Types.SourceFile, module GHC.Types.SourceText, module GHC.Types.TyThing, @@ -380,6 +428,7 @@ module TysWiredIn, module Type, module Unify, + module UniqFM, module UniqSupply, module Var, #endif @@ -415,32 +464,36 @@ import qualified GHC #if MIN_VERSION_ghc(9,0,0) -import GHC.Builtin.Names hiding (Unique, printName) +import GHC.Builtin.Names hiding (Unique, printName) import GHC.Builtin.Types import GHC.Builtin.Types.Prim import GHC.Builtin.Utils import GHC.Core.Class import GHC.Core.Coercion import GHC.Core.ConLike -import GHC.Core.DataCon hiding (dataConExTyCoVars) -import qualified GHC.Core.DataCon as DataCon -import GHC.Core.FamInstEnv +import GHC.Core.DataCon hiding (dataConExTyCoVars) +import qualified GHC.Core.DataCon as DataCon +import GHC.Core.FamInstEnv hiding (pprFamInst) import GHC.Core.InstEnv +import GHC.Types.Unique.FM #if MIN_VERSION_ghc(9,2,0) -import GHC.Core.Multiplicity (scaledThing) +import GHC.Data.Bag +import GHC.Core.Multiplicity (scaledThing) #else -import GHC.Core.Ppr.TyThing hiding (pprFamInst) -import GHC.Core.TyCo.Rep (scaledThing) +import GHC.Core.Ppr.TyThing hiding (pprFamInst) +import GHC.Core.TyCo.Rep (scaledThing) #endif import GHC.Core.PatSyn import GHC.Core.Predicate import GHC.Core.TyCo.Ppr -import qualified GHC.Core.TyCo.Rep as TyCoRep +import qualified GHC.Core.TyCo.Rep as TyCoRep import GHC.Core.TyCon -import GHC.Core.Type hiding (mkInfForAllTys, mkVisFunTys) +import GHC.Core.Type hiding (mkInfForAllTys, + mkVisFunTys) import GHC.Core.Unify import GHC.Core.Utils + #if MIN_VERSION_ghc(9,2,0) import GHC.Driver.Env #else @@ -448,120 +501,147 @@ import GHC.Driver.Types import GHC.Driver.Ways #endif -import GHC.Driver.CmdLine (Warn (..)) +import GHC.Driver.CmdLine (Warn (..)) import GHC.Driver.Hooks import GHC.Driver.Main import GHC.Driver.Monad import GHC.Driver.Phases import GHC.Driver.Pipeline import GHC.Driver.Plugins -import GHC.Driver.Session hiding (ExposePackage) -import qualified GHC.Driver.Session as DynFlags +import GHC.Driver.Session hiding (ExposePackage) +import qualified GHC.Driver.Session as DynFlags +#if MIN_VERSION_ghc(9,2,0) +import GHC.Hs (HsModule (..), SrcSpanAnn') +import GHC.Hs.Decls hiding (FunDep) +import GHC.Hs.Doc +import GHC.Hs.Expr +import GHC.Hs.Extension +import GHC.Hs.ImpExp +import GHC.Hs.Pat +import GHC.Hs.Type +import GHC.Hs.Utils hiding (collectHsBindsBinders) +import qualified GHC.Hs.Utils as GHC +#endif #if !MIN_VERSION_ghc(9,2,0) -import GHC.Hs +import GHC.Hs hiding (HsLet, LetStmt) #endif import GHC.HsToCore.Docs import GHC.HsToCore.Expr import GHC.HsToCore.Monad import GHC.Iface.Load -import GHC.Iface.Make (mkFullIface, mkIfaceTc, - mkPartialIface) +import GHC.Iface.Make (mkFullIface, mkIfaceTc, + mkPartialIface) import GHC.Iface.Recomp import GHC.Iface.Syntax import GHC.Iface.Tidy import GHC.IfaceToCore import GHC.Parser -import GHC.Parser.Header hiding (getImports) -import GHC.Parser.Lexer +import GHC.Parser.Header hiding (getImports) #if MIN_VERSION_ghc(9,2,0) -import GHC.Linker.Loader +import qualified GHC.Linker.Loader as Linker import GHC.Linker.Types +import GHC.Parser.Lexer hiding (initParserState) +import GHC.Parser.Annotation (EpAnn (..)) import GHC.Platform.Ways +import GHC.Runtime.Context (InteractiveImport (..)) #else -import GHC.Runtime.Linker +import GHC.Parser.Lexer +import qualified GHC.Runtime.Linker as Linker #endif import GHC.Rename.Names import GHC.Rename.Splice -import GHC.Runtime.Interpreter +import qualified GHC.Runtime.Interpreter as GHCi import GHC.Tc.Instance.Family import GHC.Tc.Module import GHC.Tc.Types -import GHC.Tc.Types.Evidence hiding ((<.>)) +import GHC.Tc.Types.Evidence hiding ((<.>)) import GHC.Tc.Utils.Env -import GHC.Tc.Utils.Monad hiding (Applicative (..), IORef, - MonadFix (..), MonadIO (..), allM, - anyM, concatMapM, mapMaybeM, (<$>)) -import GHC.Tc.Utils.TcType as TcType -import qualified GHC.Types.Avail as Avail +import GHC.Tc.Utils.Monad hiding (Applicative (..), IORef, + MonadFix (..), MonadIO (..), + allM, anyM, concatMapM, + mapMaybeM, (<$>)) +import GHC.Tc.Utils.TcType as TcType +import qualified GHC.Types.Avail as Avail #if MIN_VERSION_ghc(9,2,0) +import GHC.Types.Avail (greNamePrintableName) +import GHC.Types.Fixity (LexicalFixity (..)) +#endif +#if MIN_VERSION_ghc(9,2,0) import GHC.Types.Meta #endif import GHC.Types.Basic import GHC.Types.Id -import GHC.Types.Name hiding (varName) +import GHC.Types.Name hiding (varName) import GHC.Types.Name.Cache import GHC.Types.Name.Env -import GHC.Types.Name.Reader +import GHC.Types.Name.Reader hiding (GRE, gre_name, gre_imp, gre_lcl, gre_par) +import qualified GHC.Types.Name.Reader as RdrName #if MIN_VERSION_ghc(9,2,0) import GHC.Types.Name.Set -import GHC.Types.SourceFile (HscSource (..), - SourceModified (..)) +import GHC.Types.SourceFile (HscSource (..), + SourceModified (..)) import GHC.Types.SourceText +import GHC.Types.Target (Target (..), TargetId (..)) import GHC.Types.TyThing import GHC.Types.TyThing.Ppr #else import GHC.Types.Name.Set #endif -import GHC.Types.SrcLoc (BufPos, BufSpan, SrcSpan (UnhelpfulSpan), SrcLoc(UnhelpfulLoc)) -import qualified GHC.Types.SrcLoc as SrcLoc +import GHC.Types.SrcLoc (BufPos, BufSpan, + SrcLoc (UnhelpfulLoc), + SrcSpan (UnhelpfulSpan)) +import qualified GHC.Types.SrcLoc as SrcLoc import GHC.Types.Unique.Supply -import GHC.Types.Var (Var (varName), setTyVarUnique, - setVarUnique) +import GHC.Types.Var (Var (varName), setTyVarUnique, + setVarUnique) #if MIN_VERSION_ghc(9,2,0) import GHC.Unit.Finder import GHC.Unit.Home.ModInfo #endif -import GHC.Unit.Info (PackageName (..)) -import GHC.Unit.Module hiding (ModLocation (..), UnitId, - addBootSuffixLocnOut, moduleUnit, - toUnitId) -import qualified GHC.Unit.Module as Module +import GHC.Unit.Info (PackageName (..)) +import GHC.Unit.Module hiding (ModLocation (..), UnitId, + addBootSuffixLocnOut, moduleUnit, + toUnitId) +import qualified GHC.Unit.Module as Module #if MIN_VERSION_ghc(9,2,0) +import GHC.Unit.Module.Graph (mkModuleGraph) import GHC.Unit.Module.Imported import GHC.Unit.Module.ModDetails import GHC.Unit.Module.ModGuts -import GHC.Unit.Module.ModIface (IfaceExport) +import GHC.Unit.Module.ModIface (IfaceExport, ModIface (..), + ModIface_ (..)) +import GHC.Unit.Module.ModSummary (ModSummary (..)) #endif -import GHC.Unit.State (ModuleOrigin (..)) -import GHC.Utils.Error (Severity (..)) -import GHC.Utils.Panic hiding (try) -import qualified GHC.Utils.Panic.Plain as Plain +import GHC.Unit.State (ModuleOrigin (..)) +import GHC.Utils.Error (Severity (..)) +import GHC.Utils.Panic hiding (try) +import qualified GHC.Utils.Panic.Plain as Plain #else import qualified Avail -import BasicTypes hiding (Version) +import BasicTypes hiding (Version) import Class -import CmdLineParser (Warn (..)) +import CmdLineParser (Warn (..)) import ConLike import CoreUtils -import DataCon hiding (dataConExTyCoVars) +import DataCon hiding (dataConExTyCoVars) import qualified DataCon import DriverPhases import DriverPipeline import DsExpr -import DsMonad hiding (foldrM) -import DynFlags hiding (ExposePackage) +import DsMonad hiding (foldrM) +import DynFlags hiding (ExposePackage) import qualified DynFlags -import ErrUtils hiding (logInfo, mkWarnMsg) +import ErrUtils hiding (logInfo, mkWarnMsg) import ExtractDocs import FamInst import FamInstEnv import Finder #if MIN_VERSION_ghc(8,10,0) -import GHC.Hs +import GHC.Hs hiding (HsLet, LetStmt) #endif -import GHCi +import qualified GHCi import GhcMonad -import HeaderInfo hiding (getImports) +import HeaderInfo hiding (getImports) import Hooks import HscMain import HscTypes @@ -570,87 +650,97 @@ import HsBinds import HsDecls import HsDoc -import HsExpr +import HsExpr hiding (HsLet, LetStmt) import HsExtension import HsImpExp import HsLit import HsPat -import HsSyn hiding (wildCardName) -import HsTypes hiding (wildCardName) +import HsSyn hiding (wildCardName, HsLet, LetStmt) +import HsTypes hiding (wildCardName) import HsUtils #endif import Id import IfaceSyn import InstEnv -import Lexer hiding (getSrcLoc) -import Linker +import Lexer hiding (getSrcLoc) +import qualified Linker import LoadIface import MkIface -import Module hiding (ModLocation (..), UnitId, - addBootSuffixLocnOut, moduleUnitId) +import Module hiding (ModLocation (..), UnitId, + addBootSuffixLocnOut, + moduleUnitId) import qualified Module -import Name hiding (varName) +import Name hiding (varName) import NameCache import NameEnv import NameSet import Packages #if MIN_VERSION_ghc(8,8,0) -import Panic hiding (try) -import qualified PlainPanic as Plain +import Panic hiding (try) +import qualified PlainPanic as Plain #else -import Panic hiding (GhcException, try) -import qualified Panic as Plain +import Panic hiding (GhcException, try) +import qualified Panic as Plain #endif import Parser import PatSyn #if MIN_VERSION_ghc(8,8,0) import Plugins #endif -import PprTyThing hiding (pprFamInst) +import PprTyThing hiding (pprFamInst) import PrelInfo -import PrelNames hiding (Unique, printName) -import RdrName +import PrelNames hiding (Unique, printName) +import RdrName hiding (GRE, gre_name, gre_imp, gre_lcl, gre_par) +import qualified RdrName import RnNames import RnSplice import qualified SrcLoc import TcEnv -import TcEvidence hiding ((<.>)) +import TcEvidence hiding ((<.>)) import TcIface import TcRnDriver -import TcRnMonad hiding (Applicative (..), IORef, - MonadFix (..), MonadIO (..), allM, - anyM, concatMapM, foldrM, - mapMaybeM, (<$>)) +import TcRnMonad hiding (Applicative (..), IORef, + MonadFix (..), MonadIO (..), + allM, anyM, concatMapM, foldrM, + mapMaybeM, (<$>)) import TcRnTypes -import TcType hiding (mkVisFunTys) +import TcType hiding (mkVisFunTys) import qualified TcType import TidyPgm import qualified TyCoRep import TyCon -import Type hiding (mkVisFunTys) +import Type hiding (mkVisFunTys) import TysPrim import TysWiredIn import Unify +import UniqFM import UniqSupply -import Var (Var (varName), setTyVarUnique, - setVarUnique, varType) +import Var (Var (varName), setTyVarUnique, + setVarUnique, varType) #if MIN_VERSION_ghc(8,10,0) -import Coercion (coercionKind) +import Coercion (coercionKind) import Predicate -import SrcLoc (SrcSpan (UnhelpfulSpan), SrcLoc (UnhelpfulLoc)) +import SrcLoc (Located, SrcLoc (UnhelpfulLoc), + SrcSpan (UnhelpfulSpan)) #else -import SrcLoc (RealLocated, - SrcSpan (UnhelpfulSpan), - SrcLoc (UnhelpfulLoc)) +import SrcLoc (RealLocated, + SrcLoc (UnhelpfulLoc), + SrcSpan (UnhelpfulSpan)) #endif #endif + #if !MIN_VERSION_ghc(8,8,0) -import Data.List (isSuffixOf) +import Data.List (isSuffixOf) import System.FilePath #endif + +#if MIN_VERSION_ghc(9,2,0) +import Language.Haskell.Syntax hiding (FunDep) +#endif + #if !MIN_VERSION_ghc(9,0,0) type BufSpan = () type BufPos = () @@ -726,12 +816,23 @@ class HasSrcSpan a where getLoc :: a -> SrcSpan +instance HasSrcSpan SrcSpan where + getLoc = id + instance HasSrcSpan (SrcLoc.GenLocated SrcSpan a) where getLoc = GHC.getLoc --- getLoc :: GenLocated l a -> l --- getLoc = GHC.getLoc +#if MIN_VERSION_ghc(9,2,0) +instance HasSrcSpan (SrcSpanAnn' ann) where + getLoc = locA +instance HasSrcSpan (SrcLoc.GenLocated (SrcSpanAnn' ann) a) where + getLoc (L l _) = l +pattern L :: HasSrcSpan a => SrcSpan -> e -> SrcLoc.GenLocated a e +pattern L l a <- GHC.L (getLoc -> l) a +{-# COMPLETE L #-} +#endif + #elif MIN_VERSION_ghc(8,8,0) type HasSrcSpan = SrcLoc.HasSrcSpan getLoc :: SrcLoc.HasSrcSpan a => a -> SrcLoc.SrcSpan @@ -781,6 +882,9 @@ type Scaled a = a scaledThing :: Scaled a -> a scaledThing = id + +unrestricted :: a -> Scaled a +unrestricted = id #endif mkVisFunTys :: [Scaled Type] -> Type -> Type @@ -799,11 +903,9 @@ mkInvForAllTys #endif +#if !MIN_VERSION_ghc(9,2,0) splitForAllTyCoVars :: Type -> ([TyCoVar], Type) splitForAllTyCoVars = -#if MIN_VERSION_ghc(9,2,0) - TcType.splitForAllTyCoVars -#else splitForAllTys #endif @@ -857,4 +959,120 @@ type PlainGhcException = Plain.PlainGhcException #else type PlainGhcException = Plain.GhcException +#endif + +#if MIN_VERSION_ghc(9,0,0) +-- This is from the old api, but it still simplifies +pattern ConPatIn :: SrcLoc.Located (ConLikeP GhcPs) -> HsConPatDetails GhcPs -> Pat GhcPs +#if MIN_VERSION_ghc(9,2,0) +pattern ConPatIn con args <- ConPat EpAnnNotUsed (L _ (SrcLoc.noLoc -> con)) args + where + ConPatIn con args = ConPat EpAnnNotUsed (GHC.noLocA $ SrcLoc.unLoc con) args +#else +pattern ConPatIn con args = ConPat NoExtField con args +#endif +#endif + +initDynLinker, initObjLinker :: HscEnv -> IO () +initDynLinker = +#if !MIN_VERSION_ghc(9,0,0) + Linker.initDynLinker +#else + -- It errors out in GHC 9.0 and doesn't exist in 9.2 + const $ return () +#endif + +initObjLinker env = +#if !MIN_VERSION_ghc(9,2,0) + GHCi.initObjLinker env +#else + GHCi.initObjLinker (GHCi.hscInterp env) +#endif + +loadDLL :: HscEnv -> String -> IO (Maybe String) +loadDLL env = +#if !MIN_VERSION_ghc(9,2,0) + GHCi.loadDLL env +#else + GHCi.loadDLL (GHCi.hscInterp env) +#endif + +unload :: HscEnv -> [Linkable] -> IO () +unload hsc_env linkables = + Linker.unload +#if MIN_VERSION_ghc(9,2,0) + (GHCi.hscInterp hsc_env) +#endif + hsc_env linkables + +setOutputFile :: FilePath -> DynFlags -> DynFlags +setOutputFile f d = d { +#if MIN_VERSION_ghc(9,2,0) + outputFile_ = Just f +#else + outputFile = Just f +#endif + } + +isSubspanOfA :: LocatedAn la a -> LocatedAn lb b -> Bool +#if MIN_VERSION_ghc(9,2,0) +isSubspanOfA a b = SrcLoc.isSubspanOf (GHC.getLocA a) (GHC.getLocA b) +#else +isSubspanOfA a b = SrcLoc.isSubspanOf (GHC.getLoc a) (GHC.getLoc b) +#endif + +#if MIN_VERSION_ghc(9,2,0) +type LocatedAn a = GHC.LocatedAn a +#else +type LocatedAn a = GHC.Located +#endif + +#if MIN_VERSION_ghc(9,2,0) +locA :: SrcSpanAnn' a -> SrcSpan +locA = GHC.locA +#else +locA = id +#endif + +#if MIN_VERSION_ghc(9,2,0) +getLocA :: SrcLoc.GenLocated (SrcSpanAnn' a) e -> SrcSpan +getLocA = GHC.getLocA +#else +-- getLocA :: HasSrcSpan a => a -> SrcSpan +getLocA x = GHC.getLoc x +#endif + +noLocA :: a -> LocatedAn an a +#if MIN_VERSION_ghc(9,2,0) +noLocA = GHC.noLocA +#else +noLocA = GHC.noLoc +#endif + +#if !MIN_VERSION_ghc(9,2,0) +type AnnListItem = SrcLoc.SrcSpan +#endif + +#if !MIN_VERSION_ghc(9,2,0) +type NameAnn = SrcLoc.SrcSpan +#endif + +pattern GRE :: Name -> Parent -> Bool -> [ImportSpec] -> RdrName.GlobalRdrElt +{-# COMPLETE GRE #-} +#if MIN_VERSION_ghc(9,2,0) +pattern GRE{gre_name, gre_par, gre_lcl, gre_imp} <- RdrName.GRE + {gre_name = (greNamePrintableName -> gre_name) + ,gre_par, gre_lcl, gre_imp} +#else +pattern GRE{gre_name, gre_par, gre_lcl, gre_imp} = RdrName.GRE{..} +#endif + +#if MIN_VERSION_ghc(9,2,0) +collectHsBindsBinders :: CollectPass p => Bag (XRec p (HsBindLR p idR)) -> [IdP p] +collectHsBindsBinders x = GHC.collectHsBindsBinders CollNoDictBinders x +#endif + +#if !MIN_VERSION_ghc(9,2,0) +pattern HsLet xlet localBinds expr <- GHC.HsLet xlet (SrcLoc.unLoc -> localBinds) expr +pattern LetStmt xlet localBinds <- GHC.LetStmt xlet (SrcLoc.unLoc -> localBinds) #endif diff --git a/src/Development/IDE/GHC/Compat/Env.hs b/src/Development/IDE/GHC/Compat/Env.hs --- a/src/Development/IDE/GHC/Compat/Env.hs +++ b/src/Development/IDE/GHC/Compat/Env.hs @@ -32,6 +32,7 @@ -- * DynFlags Helper setBytecodeLinkerOptions, setInterpreterLinkerOptions, + Development.IDE.GHC.Compat.Env.safeImportsOn, -- * Ways Ways, Way, @@ -80,8 +81,10 @@ #endif #if MIN_VERSION_ghc(9,0,0) +#if !MIN_VERSION_ghc(9,2,0) import qualified Data.Set as Set #endif +#endif #if !MIN_VERSION_ghc(9,2,0) import Data.IORef #endif @@ -102,12 +105,7 @@ #endif hscSetFlags :: DynFlags -> HscEnv -> HscEnv -hscSetFlags df env = -#if MIN_VERSION_ghc(9,2,0) - hscSetFlags df env -#else - env { Env.hsc_dflags = df } -#endif +hscSetFlags df env = env { Env.hsc_dflags = df } initTempFs :: HscEnv -> IO HscEnv initTempFs env = do @@ -178,6 +176,13 @@ thisPackage #endif +safeImportsOn :: DynFlags -> Bool +safeImportsOn = +#if MIN_VERSION_ghc(9,2,0) + Session.safeImportsOn +#else + DynFlags.safeImportsOn +#endif #if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) type HomeUnit = Unit diff --git a/src/Development/IDE/GHC/Compat/ExactPrint.hs b/src/Development/IDE/GHC/Compat/ExactPrint.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/ExactPrint.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | This module contains compatibility constructs to write type signatures across +-- multiple ghc-exactprint versions, accepting that anything more ambitious is +-- pretty much impossible with the GHC 9.2 redesign of ghc-exactprint +module Development.IDE.GHC.Compat.ExactPrint + ( ExactPrint + , exactPrint + , makeDeltaAst + , Retrie.Annotated, pattern Annotated, astA, annsA + ) where + +#if !MIN_VERSION_ghc(9,2,0) +import Control.Arrow ((&&&)) +#else +import Development.IDE.GHC.Compat.Parser +#endif +import Language.Haskell.GHC.ExactPrint as Retrie +import qualified Retrie.ExactPrint as Retrie + +#if !MIN_VERSION_ghc(9,2,0) +class ExactPrint ast where + makeDeltaAst :: ast -> ast + makeDeltaAst = id + +instance ExactPrint ast +#endif + +#if !MIN_VERSION_ghc(9,2,0) +pattern Annotated :: ast -> Anns -> Retrie.Annotated ast +pattern Annotated {astA, annsA} <- (Retrie.astA &&& Retrie.annsA -> (astA, annsA)) +#else +pattern Annotated :: ast -> ApiAnns -> Retrie.Annotated ast +pattern Annotated {astA, annsA} <- ((,()) . Retrie.astA -> (astA, annsA)) +#endif diff --git a/src/Development/IDE/GHC/Compat/Outputable.hs b/src/Development/IDE/GHC/Compat/Outputable.hs --- a/src/Development/IDE/GHC/Compat/Outputable.hs +++ b/src/Development/IDE/GHC/Compat/Outputable.hs @@ -31,17 +31,18 @@ #if MIN_VERSION_ghc(9,2,0) +import GHC.Driver.Env import GHC.Driver.Ppr import GHC.Driver.Session import GHC.Parser.Errors import qualified GHC.Parser.Errors.Ppr as Ppr import qualified GHC.Types.Error as Error import GHC.Types.Name.Ppr +import GHC.Types.Name.Reader import GHC.Types.SourceError import GHC.Types.SrcLoc import GHC.Unit.State import GHC.Utils.Error hiding (mkWarnMsg) -import GHC.Utils.Logger import GHC.Utils.Outputable import GHC.Utils.Panic #elif MIN_VERSION_ghc(9,0,0) @@ -136,7 +137,15 @@ formatErrorWithQual :: DynFlags -> MsgEnvelope DecoratedSDoc -> String formatErrorWithQual dflags e = #if MIN_VERSION_ghc(9,2,0) - showSDoc dflags (pprLocMsgEnvelope e) + showSDoc dflags (pprNoLocMsgEnvelope e) + +pprNoLocMsgEnvelope :: Error.RenderableDiagnostic e => MsgEnvelope e -> SDoc +pprNoLocMsgEnvelope (MsgEnvelope { errMsgDiagnostic = e + , errMsgContext = unqual }) + = sdocWithContext $ \ctx -> + withErrStyle unqual $ + (formatBulleted ctx $ Error.renderDiagnostic e) + #else Out.showSDoc dflags $ Out.withPprStyle (oldMkErrStyle dflags $ errMsgContext e) @@ -152,9 +161,15 @@ type PsError = ErrMsg #endif -mkPrintUnqualifiedDefault :: GlobalRdrEnv -> PrintUnqualified -mkPrintUnqualifiedDefault = - HscTypes.mkPrintUnqualified unsafeGlobalDynFlags +mkPrintUnqualifiedDefault :: HscEnv -> GlobalRdrEnv -> PrintUnqualified +mkPrintUnqualifiedDefault env = +#if MIN_VERSION_ghc(9,2,0) + -- GHC 9.2.1 version + -- mkPrintUnqualified :: UnitEnv -> GlobalRdrEnv -> PrintUnqualified + mkPrintUnqualified (hsc_unit_env env) +#else + HscTypes.mkPrintUnqualified (hsc_dflags env) +#endif mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc mkWarnMsg = diff --git a/src/Development/IDE/GHC/Compat/Parser.hs b/src/Development/IDE/GHC/Compat/Parser.hs --- a/src/Development/IDE/GHC/Compat/Parser.hs +++ b/src/Development/IDE/GHC/Compat/Parser.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} +{-# HLINT ignore "Unused LANGUAGE pragma" #-} -- | Parser compaibility module. module Development.IDE.GHC.Compat.Parser ( @@ -14,24 +16,52 @@ #else ApiAnns, #endif - mkHsParsedModule, - mkParsedModule, +#if MIN_VERSION_ghc(9,0,0) + PsSpan(..), +#endif +#if MIN_VERSION_ghc(9,2,0) + pattern HsParsedModule, + type GHC.HsParsedModule, + Development.IDE.GHC.Compat.Parser.hpm_module, + Development.IDE.GHC.Compat.Parser.hpm_src_files, + Development.IDE.GHC.Compat.Parser.hpm_annotations, + pattern ParsedModule, + Development.IDE.GHC.Compat.Parser.pm_parsed_source, + type GHC.ParsedModule, + Development.IDE.GHC.Compat.Parser.pm_mod_summary, + Development.IDE.GHC.Compat.Parser.pm_extra_src_files, + Development.IDE.GHC.Compat.Parser.pm_annotations, +#else + GHC.HsParsedModule(..), + GHC.ParsedModule(..), +#endif mkApiAnns, -- * API Annotations Anno.AnnKeywordId(..), +#if !MIN_VERSION_ghc(9,2,0) Anno.AnnotationComment(..), +#endif ) where #if MIN_VERSION_ghc(9,0,0) +#if !MIN_VERSION_ghc(9,2,0) +import qualified GHC.Driver.Types as GHC +#endif +import qualified GHC.Parser.Annotation as Anno import qualified GHC.Parser.Lexer as Lexer +import GHC.Types.SrcLoc (PsSpan (..)) #if MIN_VERSION_ghc(9,2,0) +import GHC (pm_extra_src_files, + pm_mod_summary, + pm_parsed_source) +import qualified GHC import qualified GHC.Driver.Config as Config +import GHC.Hs (hpm_module, hpm_src_files) import GHC.Parser.Lexer hiding (initParserState) -#else -import qualified GHC.Parser.Annotation as Anno #endif #else import qualified ApiAnnotation as Anno +import qualified HscTypes as GHC import Lexer import qualified SrcLoc #endif @@ -40,6 +70,7 @@ #if !MIN_VERSION_ghc(9,2,0) import qualified Data.Map as Map +import qualified GHC #endif #if !MIN_VERSION_ghc(9,0,0) @@ -74,27 +105,36 @@ type ApiAnns = Anno.ApiAnns #endif - -mkHsParsedModule :: ParsedSource -> [FilePath] -> ApiAnns -> HsParsedModule -mkHsParsedModule parsed fps hpm_annotations = - HsParsedModule - parsed - fps -#if !MIN_VERSION_ghc(9,2,0) - hpm_annotations +#if MIN_VERSION_ghc(9,2,0) +pattern HsParsedModule :: Located HsModule -> [FilePath] -> ApiAnns -> GHC.HsParsedModule +pattern HsParsedModule + { hpm_module + , hpm_src_files + , hpm_annotations + } <- ( (,()) -> (GHC.HsParsedModule{..}, hpm_annotations)) + where + HsParsedModule hpm_module hpm_src_files hpm_annotations = + GHC.HsParsedModule hpm_module hpm_src_files #endif -mkParsedModule :: ModSummary -> ParsedSource -> [FilePath] -> ApiAnns -> ParsedModule -mkParsedModule ms parsed extra_src_files _hpm_annotations = - ParsedModule { - pm_mod_summary = ms - , pm_parsed_source = parsed - , pm_extra_src_files = extra_src_files -#if !MIN_VERSION_ghc(9,2,0) - , pm_annotations = _hpm_annotations +#if MIN_VERSION_ghc(9,2,0) +pattern ParsedModule :: ModSummary -> ParsedSource -> [FilePath] -> ApiAnns -> GHC.ParsedModule +pattern ParsedModule + { pm_mod_summary + , pm_parsed_source + , pm_extra_src_files + , pm_annotations + } <- ( (,()) -> (GHC.ParsedModule{..}, pm_annotations)) + where + ParsedModule ms parsed extra_src_files _anns = + GHC.ParsedModule + { pm_mod_summary = ms + , pm_parsed_source = parsed + , pm_extra_src_files = extra_src_files + } +{-# COMPLETE ParsedModule :: GHC.ParsedModule #-} #endif - } mkApiAnns :: PState -> ApiAnns #if MIN_VERSION_ghc(9,2,0) diff --git a/src/Development/IDE/GHC/Compat/Plugins.hs b/src/Development/IDE/GHC/Compat/Plugins.hs --- a/src/Development/IDE/GHC/Compat/Plugins.hs +++ b/src/Development/IDE/GHC/Compat/Plugins.hs @@ -17,7 +17,6 @@ #endif ) where -import GHC #if MIN_VERSION_ghc(9,0,0) #if MIN_VERSION_ghc(9,2,0) import qualified GHC.Driver.Env as Env @@ -51,7 +50,7 @@ dflags #endif applyPluginAction - (mkHsParsedModule parsed [] hpm_annotations) + (HsParsedModule parsed [] hpm_annotations) initializePlugins :: HscEnv -> IO HscEnv initializePlugins env = do diff --git a/src/Development/IDE/GHC/Compat/Units.hs b/src/Development/IDE/GHC/Compat/Units.hs --- a/src/Development/IDE/GHC/Compat/Units.hs +++ b/src/Development/IDE/GHC/Compat/Units.hs @@ -46,12 +46,14 @@ -- * Utils filterInplaceUnits, FinderCache, + showSDocForUser', ) where #if MIN_VERSION_ghc(9,0,0) #if MIN_VERSION_ghc(9,2,0) import qualified GHC.Data.ShortText as ST import GHC.Driver.Env (hsc_unit_dbs) +import GHC.Driver.Ppr import GHC.Unit.Env import GHC.Unit.External import GHC.Unit.Finder @@ -67,9 +69,11 @@ import qualified GHC.Unit.State as State import GHC.Unit.Types hiding (moduleUnit, toUnitId) import qualified GHC.Unit.Types as Unit +import GHC.Utils.Outputable #else import qualified DynFlags import FastString +import GhcPlugins (SDoc, showSDocForUser) import HscTypes import Module hiding (moduleUnitId) import qualified Module @@ -89,6 +93,7 @@ #endif import Data.Either import Data.Version +import qualified GHC #if MIN_VERSION_ghc(9,0,0) type PreloadUnitClosure = UniqSet UnitId @@ -131,12 +136,12 @@ let cached_unit_dbs = hsc_unit_dbs env (dbs,unit_state,home_unit,mconstants) <- State.initUnits (hsc_logger env) dflags1 cached_unit_dbs - dflags <- updatePlatformConstants dflags1 mconstants + dflags <- DynFlags.updatePlatformConstants dflags1 mconstants let unit_env = UnitEnv { ue_platform = targetPlatform dflags - , ue_namever = ghcNameVersion dflags + , ue_namever = DynFlags.ghcNameVersion dflags , ue_home_unit = home_unit , ue_units = unit_state } @@ -274,8 +279,11 @@ -- ------------------------------------------------------------------ #if MIN_VERSION_ghc(9,2,0) +definiteUnitId :: Definite uid -> GenUnit uid definiteUnitId = RealUnit +defUnitId :: unit -> Definite unit defUnitId = Definite +installedModule :: unit -> ModuleName -> GenModule unit installedModule = Module #elif MIN_VERSION_ghc(9,0,0) @@ -340,3 +348,10 @@ else Right p #endif isInplace p = Right p + +showSDocForUser' :: HscEnv -> GHC.PrintUnqualified -> SDoc -> String +#if MIN_VERSION_ghc(9,2,0) +showSDocForUser' env = showSDocForUser (hsc_dflags env) (unitState env) +#else +showSDocForUser' env = showSDocForUser (hsc_dflags env) +#endif diff --git a/src/Development/IDE/GHC/Compat/Util.hs b/src/Development/IDE/GHC/Compat/Util.hs --- a/src/Development/IDE/GHC/Compat/Util.hs +++ b/src/Development/IDE/GHC/Compat/Util.hs @@ -67,6 +67,10 @@ StringBuffer(..), hGetStringBuffer, stringToStringBuffer, + nextChar, + atEnd, + -- * Char + is_ident ) where #if MIN_VERSION_ghc(9,0,0) @@ -79,6 +83,7 @@ import GHC.Data.Maybe import GHC.Data.Pair import GHC.Data.StringBuffer +import GHC.Parser.CharClass (is_ident) import GHC.Types.Unique import GHC.Types.Unique.DFM import GHC.Utils.Fingerprint @@ -88,6 +93,7 @@ #else import Bag import BooleanFormula +import Ctype (is_ident) import EnumSet import qualified Exception import FastString diff --git a/src/Development/IDE/GHC/Dump.hs b/src/Development/IDE/GHC/Dump.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Dump.hs @@ -0,0 +1,337 @@ +{-# LANGUAGE CPP #-} +module Development.IDE.GHC.Dump(showAstDataHtml) where +import Data.Data hiding (Fixity) +import Development.IDE.GHC.Compat hiding (NameAnn) +#if MIN_VERSION_ghc(8,10,1) +import GHC.Hs.Dump +#else +import HsDumpAst +#endif +#if MIN_VERSION_ghc(9,2,1) +import qualified Data.ByteString as B +import Development.IDE.GHC.Compat.Util +import GHC.Hs +import Generics.SYB (ext1Q, ext2Q, extQ) +#endif +#if MIN_VERSION_ghc(9,0,1) +import GHC.Plugins +#else +import GhcPlugins +#endif +import Prelude hiding ((<>)) + +-- | Show a GHC syntax tree in HTML. +#if MIN_VERSION_ghc(9,2,1) +showAstDataHtml :: (Data a, ExactPrint a, Outputable a) => a -> SDoc +#else +showAstDataHtml :: (Data a, Outputable a) => a -> SDoc +#endif +showAstDataHtml a0 = html $ + header $$ + body (tag' [("id",text (show @String "myUL"))] "ul" $ vcat + [ +#if MIN_VERSION_ghc(9,2,1) + li (pre $ text (exactPrint a0)), + li (showAstDataHtml' a0), + li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan NoBlankEpAnnotations a0) +#else + li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan a0) +#endif + ]) + where + tag = tag' [] + tag' attrs t cont = + angleBrackets (text t <+> hcat [text a<>char '=' <>v | (a,v) <- attrs]) + <> cont + <> angleBrackets (char '/' <> text t) + ul = tag' [("class", text (show @String "nested"))] "ul" + li = tag "li" + caret x = tag' [("class", text "caret")] "span" "" <+> x + nested foo cts +#if MIN_VERSION_ghc(9,2,1) + | cts == empty = foo +#endif + | otherwise = foo $$ (caret $ ul cts) + body cts = tag "body" $ cts $$ tag "script" (text js) + header = tag "head" $ tag "style" $ text css + html = tag "html" + pre = tag "pre" +#if MIN_VERSION_ghc(9,2,1) + showAstDataHtml' :: Data a => a -> SDoc + showAstDataHtml' = + (generic + `ext1Q` list + `extQ` string `extQ` fastString `extQ` srcSpan `extQ` realSrcSpan + `extQ` annotation + `extQ` annotationModule + `extQ` annotationAddEpAnn + `extQ` annotationGrhsAnn + `extQ` annotationEpAnnHsCase + `extQ` annotationEpAnnHsLet + `extQ` annotationAnnList + `extQ` annotationEpAnnImportDecl + `extQ` annotationAnnParen + `extQ` annotationTrailingAnn + `extQ` annotationEpaLocation + `extQ` addEpAnn + `extQ` lit `extQ` litr `extQ` litt + `extQ` sourceText + `extQ` deltaPos + `extQ` epaAnchor + `extQ` anchorOp + `extQ` bytestring + `extQ` name `extQ` occName `extQ` moduleName `extQ` var + `extQ` dataCon + `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet + `extQ` fixity + `ext2Q` located + `extQ` srcSpanAnnA + `extQ` srcSpanAnnL + `extQ` srcSpanAnnP + `extQ` srcSpanAnnC + `extQ` srcSpanAnnN + ) + + where generic :: Data a => a -> SDoc + generic t = nested (text $ showConstr (toConstr t)) + (vcat (gmapQ (li . showAstDataHtml') t)) + + string :: String -> SDoc + string = text . normalize_newlines . show + + fastString :: FastString -> SDoc + fastString s = braces $ + text "FastString:" + <+> text (normalize_newlines . show $ s) + + bytestring :: B.ByteString -> SDoc + bytestring = text . normalize_newlines . show + + list [] = brackets empty + list [x] = "[]" $$ showAstDataHtml' x + list xs = nested "[]" (vcat $ map (li . showAstDataHtml') xs) + + -- Eliminate word-size dependence + lit :: HsLit GhcPs -> SDoc + lit (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s + lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s + lit (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s + lit (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s + lit l = generic l + + litr :: HsLit GhcRn -> SDoc + litr (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s + litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s + litr (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s + litr (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s + litr l = generic l + + litt :: HsLit GhcTc -> SDoc + litt (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s + litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s + litt (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s + litt (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s + litt l = generic l + + numericLit :: String -> Integer -> SourceText -> SDoc + numericLit tag x s = braces $ hsep [ text tag + , generic x + , generic s ] + + sourceText :: SourceText -> SDoc + sourceText NoSourceText = text "NoSourceText" + sourceText (SourceText src) = text "SourceText" <+> text src + + epaAnchor :: EpaLocation -> SDoc + epaAnchor (EpaSpan r) = text "EpaSpan" <+> realSrcSpan r + epaAnchor (EpaDelta d cs) = text "EpaDelta" <+> deltaPos d <+> showAstDataHtml' cs + + anchorOp :: AnchorOperation -> SDoc + anchorOp UnchangedAnchor = "UnchangedAnchor" + anchorOp (MovedAnchor dp) = "MovedAnchor " <> deltaPos dp + + deltaPos :: DeltaPos -> SDoc + deltaPos (SameLine c) = text "SameLine" <+> ppr c + deltaPos (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c + + name :: Name -> SDoc + name nm = braces $ text "Name:" <+> ppr nm + + occName n = braces $ + text "OccName:" + <+> text (occNameString n) + + moduleName :: ModuleName -> SDoc + moduleName m = braces $ text "ModuleName:" <+> ppr m + + srcSpan :: SrcSpan -> SDoc + srcSpan ss = char ' ' <> + (hang (ppr ss) 1 + -- TODO: show annotations here + (text "")) + + realSrcSpan :: RealSrcSpan -> SDoc + realSrcSpan ss = braces $ char ' ' <> + (hang (ppr ss) 1 + -- TODO: show annotations here + (text "")) + + addEpAnn :: AddEpAnn -> SDoc + addEpAnn (AddEpAnn a s) = text "AddEpAnn" <+> ppr a <+> epaAnchor s + + var :: Var -> SDoc + var v = braces $ text "Var:" <+> ppr v + + dataCon :: DataCon -> SDoc + dataCon c = braces $ text "DataCon:" <+> ppr c + + bagRdrName:: Bag (LocatedA (HsBind GhcPs)) -> SDoc + bagRdrName bg = braces $ + text "Bag(LocatedA (HsBind GhcPs)):" + $$ (list . bagToList $ bg) + + bagName :: Bag (LocatedA (HsBind GhcRn)) -> SDoc + bagName bg = braces $ + text "Bag(LocatedA (HsBind Name)):" + $$ (list . bagToList $ bg) + + bagVar :: Bag (LocatedA (HsBind GhcTc)) -> SDoc + bagVar bg = braces $ + text "Bag(LocatedA (HsBind Var)):" + $$ (list . bagToList $ bg) + + nameSet ns = braces $ + text "NameSet:" + $$ (list . nameSetElemsStable $ ns) + + fixity :: Fixity -> SDoc + fixity fx = braces $ + text "Fixity:" + <+> ppr fx + + located :: (Data a, Data b) => GenLocated a b -> SDoc + located (L ss a) + = nested "L" $ (li (showAstDataHtml' ss) $$ li (showAstDataHtml' a)) + + -- ------------------------- + + annotation :: EpAnn [AddEpAnn] -> SDoc + annotation = annotation' (text "EpAnn [AddEpAnn]") + + annotationModule :: EpAnn AnnsModule -> SDoc + annotationModule = annotation' (text "EpAnn AnnsModule") + + annotationAddEpAnn :: EpAnn AddEpAnn -> SDoc + annotationAddEpAnn = annotation' (text "EpAnn AddEpAnn") + + annotationGrhsAnn :: EpAnn GrhsAnn -> SDoc + annotationGrhsAnn = annotation' (text "EpAnn GrhsAnn") + + annotationEpAnnHsCase :: EpAnn EpAnnHsCase -> SDoc + annotationEpAnnHsCase = annotation' (text "EpAnn EpAnnHsCase") + + annotationEpAnnHsLet :: EpAnn AnnsLet -> SDoc + annotationEpAnnHsLet = annotation' (text "EpAnn AnnsLet") + + annotationAnnList :: EpAnn AnnList -> SDoc + annotationAnnList = annotation' (text "EpAnn AnnList") + + annotationEpAnnImportDecl :: EpAnn EpAnnImportDecl -> SDoc + annotationEpAnnImportDecl = annotation' (text "EpAnn EpAnnImportDecl") + + annotationAnnParen :: EpAnn AnnParen -> SDoc + annotationAnnParen = annotation' (text "EpAnn AnnParen") + + annotationTrailingAnn :: EpAnn TrailingAnn -> SDoc + annotationTrailingAnn = annotation' (text "EpAnn TrailingAnn") + + annotationEpaLocation :: EpAnn EpaLocation -> SDoc + annotationEpaLocation = annotation' (text "EpAnn EpaLocation") + + annotation' :: forall a .(Data a, Typeable a) + => SDoc -> EpAnn a -> SDoc + annotation' tag anns = nested (text $ showConstr (toConstr anns)) + (vcat (map li $ gmapQ showAstDataHtml' anns)) + + -- ------------------------- + + srcSpanAnnA :: SrcSpanAnn' (EpAnn AnnListItem) -> SDoc + srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA") + + srcSpanAnnL :: SrcSpanAnn' (EpAnn AnnList) -> SDoc + srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL") + + srcSpanAnnP :: SrcSpanAnn' (EpAnn AnnPragma) -> SDoc + srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP") + + srcSpanAnnC :: SrcSpanAnn' (EpAnn AnnContext) -> SDoc + srcSpanAnnC = locatedAnn'' (text "SrcSpanAnnC") + + srcSpanAnnN :: SrcSpanAnn' (EpAnn NameAnn) -> SDoc + srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN") + + locatedAnn'' :: forall a. (Typeable a, Data a) + => SDoc -> SrcSpanAnn' a -> SDoc + locatedAnn'' tag ss = + case cast ss of + Just ((SrcSpanAnn ann s) :: SrcSpanAnn' a) -> + nested "SrcSpanAnn" $ ( + li(showAstDataHtml' ann) + $$ li(srcSpan s)) + Nothing -> text "locatedAnn:unmatched" <+> tag + <+> (text (showConstr (toConstr ss))) +#endif + + +normalize_newlines :: String -> String +normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs +normalize_newlines (x:xs) = x:normalize_newlines xs +normalize_newlines [] = [] + +css :: String +css = unlines + [ "body {background-color: black; color: white ;}" + , "/* Remove default bullets */" + , "ul, #myUL {" + , " list-style-type: none;" + , "}" + , "/* Remove margins and padding from the parent ul */" + , "#myUL {" + , " margin: 0; " + , " padding: 0; " + , "} " + , "/* Style the caret/arrow */ " + , ".caret { " + , " cursor: pointer; " + , " user-select: none; /* Prevent text selection */" + , "} " + , "/* Create the caret/arrow with a unicode, and style it */" + , ".caret::before { " + , " content: \"\\25B6 \"; " + , " color: white; " + , " display: inline-block; " + , " margin-right: 6px; " + , "} " + , "/* Rotate the caret/arrow icon when clicked on (using JavaScript) */" + , ".caret-down::before { " + , " transform: rotate(90deg); " + , "} " + , "/* Hide the nested list */ " + , ".nested { " + , " display: none; " + , "} " + , "/* Show the nested list when the user clicks on the caret/arrow (with JavaScript) */" + , ".active { " + , " display: block;}" + ] + +js :: String +js = unlines + [ "var toggler = document.getElementsByClassName(\"caret\");" + , "var i;" + , "for (i = 0; i < toggler.length; i++) {" + , " toggler[i].addEventListener(\"click\", function() {" + , " this.parentElement.querySelector(\".nested\").classList.toggle(\"active\");" + , " this.classList.toggle(\"caret-down\");" + , " }); }" + ] diff --git a/src/Development/IDE/GHC/Error.hs b/src/Development/IDE/GHC/Error.hs --- a/src/Development/IDE/GHC/Error.hs +++ b/src/Development/IDE/GHC/Error.hs @@ -79,7 +79,7 @@ realSrcLocToPosition :: RealSrcLoc -> Position realSrcLocToPosition real = - Position (srcLocLine real - 1) (srcLocCol real - 1) + Position (fromIntegral $ srcLocLine real - 1) (fromIntegral $ srcLocCol real - 1) -- | Extract a file name from a GHC SrcSpan (use message for unhelpful ones) -- FIXME This may not be an _absolute_ file name, needs fixing. @@ -111,7 +111,7 @@ positionToRealSrcLoc :: NormalizedFilePath -> Position -> RealSrcLoc positionToRealSrcLoc nfp (Position l c)= - Compat.mkRealSrcLoc (fromString $ fromNormalizedFilePath nfp) (l + 1) (c + 1) + Compat.mkRealSrcLoc (fromString $ fromNormalizedFilePath nfp) (fromIntegral $ l + 1) (fromIntegral $ c + 1) isInsideSrcSpan :: Position -> SrcSpan -> Bool p `isInsideSrcSpan` r = case srcSpanToRange r of diff --git a/src/Development/IDE/GHC/ExactPrint.hs b/src/Development/IDE/GHC/ExactPrint.hs --- a/src/Development/IDE/GHC/ExactPrint.hs +++ b/src/Development/IDE/GHC/ExactPrint.hs @@ -1,9 +1,12 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +-- | This module hosts various abstractions and utility functions to work with ghc-exactprint. module Development.IDE.GHC.ExactPrint ( Graft(..), graftDecls, @@ -18,30 +21,41 @@ graftSmallestDeclsWithM, transform, transformM, + ExactPrint(..), +#if !MIN_VERSION_ghc(9,2,0) useAnnotatedSource, + Anns, + Annotate, + setPrecedingLinesT, +#else + addParens, + addParensToCtxt, + modifyAnns, + removeComma, + -- * Helper function + eqSrcSpan, + epl, + epAnn, + removeTrailingComma, +#endif annotateParsedSource, getAnnotatedParsedSourceRule, GetAnnotatedParsedSource(..), ASTElement (..), ExceptStringT (..), - Annotated(..), TransformT, - Anns, - Annotate, - setPrecedingLinesT, - -- * Helper function - eqSrcSpan, ) where import Control.Applicative (Alternative) -import Control.Arrow +import Control.Arrow (right, (***)) import Control.Monad import qualified Control.Monad.Fail as Fail import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Monad.Zip +import Data.Bifunctor import Data.Bool (bool) import qualified Data.DList as DL import Data.Either.Extra (mapLeft) @@ -64,15 +78,26 @@ import Generics.SYB import Generics.SYB.GHC import Ide.PluginUtils -import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Parsers import Language.LSP.Types import Language.LSP.Types.Capabilities (ClientCapabilities) -import Retrie.ExactPrint hiding (parseDecl, - parseExpr, +import Retrie.ExactPrint hiding (Annotated (..), + parseDecl, parseExpr, parsePattern, parseType) - +#if MIN_VERSION_ghc(9,2,0) +import GHC (EpAnn (..), + NameAdornment (NameParens), + NameAnn (..), + SrcSpanAnn' (SrcSpanAnn), + SrcSpanAnnA, + TrailingAnn (AddCommaAnn), + emptyComments, + spanAsAnchor) +import GHC.Parser.Annotation (AnnContext (..), + DeltaPos (SameLine), + EpaLocation (EpaDelta)) +#endif ------------------------------------------------------------------------------ @@ -89,9 +114,15 @@ pm <- use GetParsedModuleWithComments nfp return ([], fmap annotateParsedSource pm) +#if MIN_VERSION_ghc(9,2,0) annotateParsedSource :: ParsedModule -> Annotated ParsedSource +annotateParsedSource (ParsedModule _ ps _ _) = unsafeMkA (makeDeltaAst ps) 0 +#else +annotateParsedSource :: ParsedModule -> Annotated ParsedSource annotateParsedSource = fixAnns +#endif +#if !MIN_VERSION_ghc(9,2,0) useAnnotatedSource :: String -> IdeState -> @@ -99,6 +130,8 @@ IO (Maybe (Annotated ParsedSource)) useAnnotatedSource herald state nfp = runAction herald state (use GetAnnotatedParsedSource nfp) +#endif + ------------------------------------------------------------------------------ {- | A transformation for grafting source trees together. Use the semigroup @@ -214,8 +247,8 @@ ast@, or this is a no-op. -} graft' :: - forall ast a. - (Data a, ASTElement ast) => + forall ast a l. + (Data a, Typeable l, ASTElement l ast) => -- | Do we need to insert a space before this grafting? In do blocks, the -- answer is no, or we will break layout. But in function applications, -- the answer is yes, or the function call won't get its argument. Yikes! @@ -223,21 +256,26 @@ -- More often the answer is yes, so when in doubt, use that. Bool -> SrcSpan -> - Located ast -> + LocatedAn l ast -> Graft (Either String) a graft' needs_space dst val = Graft $ \dflags a -> do +#if MIN_VERSION_ghc(9,2,0) + val' <- annotate dflags needs_space val +#else (anns, val') <- annotate dflags needs_space val modifyAnnsT $ mappend anns +#endif pure $ everywhere' ( mkT $ \case - (L src _ :: Located ast) - | src `eqSrcSpan` dst -> val' + (L src _ :: LocatedAn l ast) + | locA src `eqSrcSpan` dst -> val' l -> l ) a + -- | Like 'graft', but specialized to 'LHsExpr', and intelligently inserts -- parentheses if they're necessary. graftExpr :: @@ -254,12 +292,11 @@ dflags a - getNeedsSpaceAndParenthesize :: - (ASTElement ast, Data a) => + (ASTElement l ast, Data a) => SrcSpan -> a -> - (Bool, Located ast -> Located ast) + (Bool, LocatedAn l ast -> LocatedAn l ast) getNeedsSpaceAndParenthesize dst a = -- Traverse the tree, looking for our replacement node. But keep track of -- the context (parent HsExpr constructor) we're in while we do it. This @@ -267,7 +304,7 @@ let (needs_parens, needs_space) = everythingWithContext (Nothing, Nothing) (<>) ( mkQ (mempty, ) $ \x s -> case x of - (L src _ :: LHsExpr GhcPs) | src `eqSrcSpan` dst -> + (L src _ :: LHsExpr GhcPs) | locA src `eqSrcSpan` dst -> (s, s) L _ x' -> (mempty, Just *** Just $ needsParensSpace x') ) a @@ -291,40 +328,54 @@ ( mkM $ \case val@(L src _ :: LHsExpr GhcPs) - | src `eqSrcSpan` dst -> do + | locA src `eqSrcSpan` dst -> do mval <- trans val case mval of Just val' -> do +#if MIN_VERSION_ghc(9,2,0) + val'' <- + hoistTransform (either Fail.fail pure) + (annotate @AnnListItem @(HsExpr GhcPs) dflags needs_space (mk_parens val')) + pure val'' +#else (anns, val'') <- hoistTransform (either Fail.fail pure) - (annotate @(HsExpr GhcPs) dflags needs_space (mk_parens val')) + (annotate @AnnListItem @(HsExpr GhcPs) dflags needs_space (mk_parens val')) modifyAnnsT $ mappend anns pure val'' +#endif Nothing -> pure val l -> pure l ) a graftWithM :: - forall ast m a. - (Fail.MonadFail m, Data a, ASTElement ast) => + forall ast m a l. + (Fail.MonadFail m, Data a, Typeable l, ASTElement l ast) => SrcSpan -> - (Located ast -> TransformT m (Maybe (Located ast))) -> + (LocatedAn l ast -> TransformT m (Maybe (LocatedAn l ast))) -> Graft m a graftWithM dst trans = Graft $ \dflags a -> do everywhereM' ( mkM $ \case - val@(L src _ :: Located ast) - | src `eqSrcSpan` dst -> do + val@(L src _ :: LocatedAn l ast) + | locA src `eqSrcSpan` dst -> do mval <- trans val case mval of Just val' -> do +#if MIN_VERSION_ghc(9,2,0) + val'' <- + hoistTransform (either Fail.fail pure) $ + annotate dflags True $ maybeParensAST val' + pure val'' +#else (anns, val'') <- hoistTransform (either Fail.fail pure) $ annotate dflags True $ maybeParensAST val' modifyAnnsT $ mappend anns pure val'' +#endif Nothing -> pure val l -> pure l ) @@ -368,7 +419,7 @@ annotateDecl dflags decl let go [] = DL.empty go (L src e : rest) - | src `eqSrcSpan` dst = DL.fromList decs <> DL.fromList rest + | locA src `eqSrcSpan` dst = DL.fromList decs <> DL.fromList rest | otherwise = DL.singleton (L src e) <> go rest modifyDeclsT (pure . DL.toList . go) a @@ -381,7 +432,7 @@ graftSmallestDeclsWithM dst toDecls = Graft $ \dflags a -> do let go [] = pure DL.empty go (e@(L src _) : rest) - | dst `isSubspanOf` src = toDecls e >>= \case + | dst `isSubspanOf` locA src = toDecls e >>= \case Just decs0 -> do decs <- forM decs0 $ \decl -> annotateDecl dflags decl @@ -399,7 +450,7 @@ graftDeclsWithM dst toDecls = Graft $ \dflags a -> do let go [] = pure DL.empty go (e@(L src _) : rest) - | src `eqSrcSpan` dst = toDecls e >>= \case + | locA src `eqSrcSpan` dst = toDecls e >>= \case Just decs0 -> do decs <- forM decs0 $ \decl -> hoistTransform (either Fail.fail pure) $ @@ -410,9 +461,9 @@ modifyDeclsT (fmap DL.toList . go) a -class (Data ast, Outputable ast) => ASTElement ast where - parseAST :: Parser (Located ast) - maybeParensAST :: Located ast -> Located ast +class (Data ast, Typeable l, Outputable l, Outputable ast) => ASTElement l ast | ast -> l where + parseAST :: Parser (LocatedAn l ast) + maybeParensAST :: LocatedAn l ast -> LocatedAn l ast {- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with the given @Located ast@. The node at that position must already be a @Located ast@, or this is a no-op. @@ -421,16 +472,16 @@ forall a. (Data a) => SrcSpan -> - Located ast -> + LocatedAn l ast -> Graft (Either String) a graft dst = graft' True dst . maybeParensAST -instance p ~ GhcPs => ASTElement (HsExpr p) where +instance p ~ GhcPs => ASTElement AnnListItem (HsExpr p) where parseAST = parseExpr maybeParensAST = parenthesize graft = graftExpr -instance p ~ GhcPs => ASTElement (Pat p) where +instance p ~ GhcPs => ASTElement AnnListItem (Pat p) where #if __GLASGOW_HASKELL__ == 808 parseAST = fmap (fmap $ right $ second dL) . parsePattern maybeParensAST = dL . parenthesizePat appPrec . unLoc @@ -439,41 +490,53 @@ maybeParensAST = parenthesizePat appPrec #endif -instance p ~ GhcPs => ASTElement (HsType p) where +instance p ~ GhcPs => ASTElement AnnListItem (HsType p) where parseAST = parseType maybeParensAST = parenthesizeHsType appPrec -instance p ~ GhcPs => ASTElement (HsDecl p) where +instance p ~ GhcPs => ASTElement AnnListItem (HsDecl p) where parseAST = parseDecl maybeParensAST = id -instance p ~ GhcPs => ASTElement (ImportDecl p) where +instance p ~ GhcPs => ASTElement AnnListItem (ImportDecl p) where parseAST = parseImport maybeParensAST = id -instance ASTElement RdrName where +instance ASTElement NameAnn RdrName where parseAST df fp = parseWith df fp parseIdentifier maybeParensAST = id ------------------------------------------------------------------------------ +#if !MIN_VERSION_ghc(9,2,0) -- | Dark magic I stole from retrie. No idea what it does. fixAnns :: ParsedModule -> Annotated ParsedSource fixAnns ParsedModule {..} = let ranns = relativiseApiAnns pm_parsed_source pm_annotations in unsafeMkA pm_parsed_source ranns 0 +#endif ------------------------------------------------------------------------------ -- | Given an 'LHSExpr', compute its exactprint annotations. -- Note that this function will throw away any existing annotations (and format) -annotate :: ASTElement ast => DynFlags -> Bool -> Located ast -> TransformT (Either String) (Anns, Located ast) +annotate :: (ASTElement l ast, Outputable l) +#if MIN_VERSION_ghc(9,2,0) + => DynFlags -> Bool -> LocatedAn l ast -> TransformT (Either String) (LocatedAn l ast) +#else + => DynFlags -> Bool -> LocatedAn l ast -> TransformT (Either String) (Anns, LocatedAn l ast) +#endif annotate dflags needs_space ast = do uniq <- show <$> uniqueSrcSpanT let rendered = render dflags ast +#if MIN_VERSION_ghc(9,2,0) + expr' <- lift $ mapLeft show $ parseAST dflags uniq rendered + pure expr' +#else (anns, expr') <- lift $ mapLeft show $ parseAST dflags uniq rendered let anns' = setPrecedingLines expr' 0 (bool 0 1 needs_space) anns - pure (anns', expr') + pure (anns',expr') +#endif -- | Given an 'LHsDecl', compute its exactprint annotations. annotateDecl :: DynFlags -> LHsDecl GhcPs -> TransformT (Either String) (LHsDecl GhcPs) @@ -489,6 +552,17 @@ let set_matches matches = ValD ext fb { fun_matches = mg { mg_alts = L alt_src matches }} +#if MIN_VERSION_ghc(9,2,0) + alts' <- for alts $ \alt -> do + uniq <- show <$> uniqueSrcSpanT + let rendered = render dflags $ set_matches [alt] + lift (mapLeft show $ parseDecl dflags uniq rendered) >>= \case + (L _ (ValD _ FunBind { fun_matches = MG { mg_alts = L _ [alt']}})) + -> pure alt' + _ -> lift $ Left "annotateDecl: didn't parse a single FunBind match" + + pure $ L src $ set_matches alts' +#else (anns', alts') <- fmap unzip $ for alts $ \alt -> do uniq <- show <$> uniqueSrcSpanT let rendered = render dflags $ set_matches [alt] @@ -499,13 +573,18 @@ modifyAnnsT $ mappend $ fold anns' pure $ L src $ set_matches alts' +#endif annotateDecl dflags ast = do uniq <- show <$> uniqueSrcSpanT let rendered = render dflags ast +#if MIN_VERSION_ghc(9,2,0) + lift $ mapLeft show $ parseDecl dflags uniq rendered +#else (anns, expr') <- lift $ mapLeft show $ parseDecl dflags uniq rendered let anns' = setPrecedingLines expr' 1 0 anns modifyAnnsT $ mappend anns' pure expr' +#endif ------------------------------------------------------------------------------ @@ -525,3 +604,60 @@ -- Ignores the (Maybe BufSpan) field of SrcSpan's. eqSrcSpan :: SrcSpan -> SrcSpan -> Bool eqSrcSpan l r = leftmost_smallest l r == EQ + +-- | Equality on SrcSpan's. +-- Ignores the (Maybe BufSpan) field of SrcSpan's. +#if MIN_VERSION_ghc(9,2,0) +eqSrcSpanA :: SrcAnn la -> SrcAnn b -> Bool +eqSrcSpanA l r = leftmost_smallest (locA l) (locA r) == EQ +#else +eqSrcSpanA :: SrcSpan -> SrcSpan -> Bool +eqSrcSpanA l r = leftmost_smallest l r == EQ +#endif + +#if MIN_VERSION_ghc(9,2,0) +addParensToCtxt :: Maybe EpaLocation -> AnnContext -> AnnContext +addParensToCtxt close_dp = addOpen . addClose + where + addOpen it@AnnContext{ac_open = []} = it{ac_open = [epl 0]} + addOpen other = other + addClose it + | Just c <- close_dp = it{ac_close = [c]} + | AnnContext{ac_close = []} <- it = it{ac_close = [epl 0]} + | otherwise = it + +epl :: Int -> EpaLocation +epl n = EpaDelta (SameLine n) [] + +epAnn :: SrcSpan -> ann -> EpAnn ann +epAnn srcSpan anns = EpAnn (spanAsAnchor srcSpan) anns emptyComments + +modifyAnns :: LocatedAn a ast -> (a -> a) -> LocatedAn a ast +modifyAnns x f = first ((fmap.fmap) f) x + +removeComma :: SrcSpanAnnA -> SrcSpanAnnA +removeComma it@(SrcSpanAnn EpAnnNotUsed _) = it +removeComma (SrcSpanAnn (EpAnn anc (AnnListItem as) cs) l) + = (SrcSpanAnn (EpAnn anc (AnnListItem (filter (not . isCommaAnn) as)) cs) l) + where + isCommaAnn AddCommaAnn{} = True + isCommaAnn _ = False + +addParens :: Bool -> GHC.NameAnn -> GHC.NameAnn +addParens True it@NameAnn{} = + it{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0 } +addParens True it@NameAnnCommas{} = + it{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0 } +addParens True it@NameAnnOnly{} = + it{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0 } +addParens True NameAnnTrailing{..} = + NameAnn{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0, nann_name = epl 0, ..} +addParens _ it = it + +removeTrailingComma :: GenLocated SrcSpanAnnA ast -> GenLocated SrcSpanAnnA ast +removeTrailingComma = flip modifyAnns $ \(AnnListItem l) -> AnnListItem $ filter (not . isCommaAnn) l + +isCommaAnn :: TrailingAnn -> Bool +isCommaAnn AddCommaAnn{} = True +isCommaAnn _ = False +#endif diff --git a/src/Development/IDE/GHC/Orphans.hs b/src/Development/IDE/GHC/Orphans.hs --- a/src/Development/IDE/GHC/Orphans.hs +++ b/src/Development/IDE/GHC/Orphans.hs @@ -9,6 +9,9 @@ -- Note that the 'NFData' instances may not be law abiding. module Development.IDE.GHC.Orphans() where +#if MIN_VERSION_ghc(9,2,0) +import GHC.Parser.Annotation +#endif #if MIN_VERSION_ghc(9,0,0) import GHC.Data.Bag import GHC.Data.FastString @@ -25,7 +28,6 @@ import Unique (getKey) #endif -import GHC import Retrie.ExactPrint (Annotated) @@ -34,9 +36,9 @@ import Control.DeepSeq import Data.Aeson +import Data.Bifunctor (Bifunctor (..)) import Data.Hashable import Data.String (IsString (fromString)) -import Data.Text (Text) -- Orphan instances for types from the GHC API. instance Show CoreModule where show = prettyPrint @@ -93,6 +95,19 @@ rnf = rwhnf #endif +#if MIN_VERSION_ghc(9,2,0) +instance Ord FastString where + compare a b = if a == b then EQ else compare (fs_sbs a) (fs_sbs b) + +instance NFData (SrcSpanAnn' a) where + rnf = rwhnf + +instance Bifunctor (GenLocated) where + bimap f g (L l x) = L (f l) (g x) + +deriving instance Functor SrcSpanAnn' +#endif + instance NFData ParsedModule where rnf = rwhnf @@ -122,7 +137,7 @@ rnf = rwhnf srcSpanFileTag, srcSpanStartLineTag, srcSpanStartColTag, - srcSpanEndLineTag, srcSpanEndColTag :: Text + srcSpanEndLineTag, srcSpanEndColTag :: String srcSpanFileTag = "srcSpanFile" srcSpanStartLineTag = "srcSpanStartLine" srcSpanStartColTag = "srcSpanStartCol" @@ -132,24 +147,24 @@ instance ToJSON RealSrcSpan where toJSON spn = object - [ srcSpanFileTag .= unpackFS (srcSpanFile spn) - , srcSpanStartLineTag .= srcSpanStartLine spn - , srcSpanStartColTag .= srcSpanStartCol spn - , srcSpanEndLineTag .= srcSpanEndLine spn - , srcSpanEndColTag .= srcSpanEndCol spn + [ fromString srcSpanFileTag .= unpackFS (srcSpanFile spn) + , fromString srcSpanStartLineTag .= srcSpanStartLine spn + , fromString srcSpanStartColTag .= srcSpanStartCol spn + , fromString srcSpanEndLineTag .= srcSpanEndLine spn + , fromString srcSpanEndColTag .= srcSpanEndCol spn ] instance FromJSON RealSrcSpan where parseJSON = withObject "object" $ \obj -> do - file <- fromString <$> (obj .: srcSpanFileTag) + file <- fromString <$> (obj .: fromString srcSpanFileTag) mkRealSrcSpan <$> (mkRealSrcLoc file - <$> obj .: srcSpanStartLineTag - <*> obj .: srcSpanStartColTag + <$> obj .: fromString srcSpanStartLineTag + <*> obj .: fromString srcSpanStartColTag ) <*> (mkRealSrcLoc file - <$> obj .: srcSpanEndLineTag - <*> obj .: srcSpanEndColTag + <$> obj .: fromString srcSpanEndLineTag + <*> obj .: fromString srcSpanEndColTag ) instance NFData Type where diff --git a/src/Development/IDE/GHC/Util.hs b/src/Development/IDE/GHC/Util.hs --- a/src/Development/IDE/GHC/Util.hs +++ b/src/Development/IDE/GHC/Util.hs @@ -28,49 +28,25 @@ setHieDir, dontWriteHieFiles, disableWarningsAsErrors, - ) where + traceAst) where #if MIN_VERSION_ghc(9,2,0) -import GHC -import GHC.Core.Multiplicity -import qualified GHC.Core.TyCo.Rep as TyCoRep import GHC.Data.FastString import GHC.Data.StringBuffer import GHC.Driver.Env -import GHC.Driver.Env.Types import GHC.Driver.Monad import GHC.Driver.Session hiding (ExposePackage) -import qualified GHC.Driver.Session as DynFlags -import GHC.Hs.Extension -import qualified GHC.Hs.Type as GHC -import GHC.Iface.Env (updNameCache) -import GHC.Iface.Make (mkIfaceExports) -import qualified GHC.Linker.Types as LinkerTypes import GHC.Parser.Lexer import GHC.Runtime.Context -import GHC.Tc.Types (TcGblEnv (tcg_exports)) -import GHC.Tc.Utils.TcType (pprSigmaType) -import GHC.Types.Avail -import GHC.Types.Name.Cache import GHC.Types.Name.Occurrence import GHC.Types.Name.Reader import GHC.Types.SrcLoc -import qualified GHC.Types.SrcLoc as SrcLoc -import GHC.Unit.Env -import GHC.Unit.Info (PackageName) -import qualified GHC.Unit.Info as Packages -import qualified GHC.Unit.Module.Location as Module import GHC.Unit.Module.ModDetails import GHC.Unit.Module.ModGuts -import GHC.Unit.Module.ModIface (mi_mod_hash) -import GHC.Unit.Module.Name (moduleNameSlashes) -import qualified GHC.Unit.State as Packages -import GHC.Unit.Types (IsBootInterface (..), - unitString) -import qualified GHC.Unit.Types as Module import GHC.Utils.Fingerprint import GHC.Utils.Outputable -import qualified GHC.Utils.Outputable as Outputable +#else +import Development.IDE.GHC.Compat.Util #endif import Control.Concurrent import Control.Exception as E @@ -79,17 +55,22 @@ import Data.ByteString.Internal (ByteString (..)) import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Lazy as LBS +import Data.Data (Data) import Data.IORef import Data.List.Extra import Data.Maybe import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as T +import Data.Time.Clock.POSIX (POSIXTime, getCurrentTime, + utcTimeToPOSIXSeconds) import Data.Typeable +import qualified Data.Unique as U +import Debug.Trace import Development.IDE.GHC.Compat as GHC import qualified Development.IDE.GHC.Compat.Parser as Compat import qualified Development.IDE.GHC.Compat.Units as Compat -import Development.IDE.GHC.Compat.Util +import Development.IDE.GHC.Dump (showAstDataHtml) import Development.IDE.Types.Location import Foreign.ForeignPtr import Foreign.Ptr @@ -101,8 +82,11 @@ import GHC.IO.Exception import GHC.IO.Handle.Internals import GHC.IO.Handle.Types - +import GHC.Stack +import System.Environment.Blank (getEnvDefault) import System.FilePath +import System.IO.Unsafe +import Text.Printf ---------------------------------------------------------------------- @@ -300,3 +284,38 @@ ioe_dupHandlesNotCompatible h = ioException (IOError (Just h) IllegalOperation "hDuplicateTo" "handles are incompatible" Nothing Nothing) + +-------------------------------------------------------------------------------- +-- Tracing exactprint terms + +{-# NOINLINE timestamp #-} +timestamp :: POSIXTime +timestamp = utcTimeToPOSIXSeconds $ unsafePerformIO getCurrentTime + +debugAST :: Bool +debugAST = unsafePerformIO (getEnvDefault "GHCIDE_DEBUG_AST" "0") == "1" + +-- | Prints an 'Outputable' value to stderr and to an HTML file for further inspection +traceAst :: (Data a, ExactPrint a, Outputable a, HasCallStack) => String -> a -> a +traceAst lbl x + | debugAST = trace doTrace x + | otherwise = x + where +#if MIN_VERSION_ghc(9,2,0) + renderDump = renderWithContext defaultSDocContext{sdocStyle = defaultDumpStyle, sdocPprDebug = True} +#else + renderDump = unsafePrintSDoc +#endif + htmlDump = showAstDataHtml x + doTrace = unsafePerformIO $ do + u <- U.newUnique + let htmlDumpFileName = printf "/tmp/hls/%s-%s-%d.html" (show timestamp) lbl (U.hashUnique u) + writeFile htmlDumpFileName $ renderDump htmlDump + return $ unlines + [prettyCallStack callStack ++ ":" +#if MIN_VERSION_ghc(9,2,0) + , exactPrint x +#endif + , "file://" ++ htmlDumpFileName] + + diff --git a/src/Development/IDE/Import/DependencyInformation.hs b/src/Development/IDE/Import/DependencyInformation.hs --- a/src/Development/IDE/Import/DependencyInformation.hs +++ b/src/Development/IDE/Import/DependencyInformation.hs @@ -166,7 +166,7 @@ instance NFData ModuleParseError -- | Error when trying to locate a module. -data LocateError = LocateError [Diagnostic] +newtype LocateError = LocateError [Diagnostic] deriving (Eq, Show, Generic) instance NFData LocateError @@ -316,7 +316,7 @@ where go :: Int -> IntSet -> IntSet go k i = - let outwards = fromMaybe IntSet.empty (IntMap.lookup k depReverseModuleDeps) + let outwards = IntMap.findWithDefault IntSet.empty k depReverseModuleDeps res = IntSet.union i outwards new = IntSet.difference i outwards in IntSet.foldr go res new diff --git a/src/Development/IDE/LSP/LanguageServer.hs b/src/Development/IDE/LSP/LanguageServer.hs --- a/src/Development/IDE/LSP/LanguageServer.hs +++ b/src/Development/IDE/LSP/LanguageServer.hs @@ -38,8 +38,16 @@ import Development.IDE.LSP.HoverDefinition import Development.IDE.Types.Logger +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Development.IDE.Types.Shake (WithHieDb) import System.IO.Unsafe (unsafeInterleaveIO) +issueTrackerUrl :: T.Text +issueTrackerUrl = "https://github.com/haskell/haskell-language-server/issues" + +-- used to smuggle RankNType WithHieDb through dbMVar +newtype WithHieDbShield = WithHieDbShield WithHieDb + runLanguageServer :: forall config. (Show config) => LSP.Options @@ -49,16 +57,21 @@ -> config -> (config -> Value -> Either T.Text config) -> LSP.Handlers (ServerM config) - -> (LSP.LanguageContextEnv config -> VFSHandle -> Maybe FilePath -> HieDb -> IndexQueue -> IO IdeState) + -> (LSP.LanguageContextEnv config -> VFSHandle -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState) -> IO () runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChange userHandlers getIdeState = do -- This MVar becomes full when the server thread exits or we receive exit message from client. - -- LSP loop will be canceled when it's full. + -- LSP server will be canceled when it's full. clientMsgVar <- newEmptyMVar -- Forcefully exit let exit = void $ tryPutMVar clientMsgVar () + -- An MVar to control the lifetime of the reactor loop. + -- The loop will be stopped and resources freed when it's full + reactorLifetime <- newEmptyMVar + let stopReactorLoop = void $ tryPutMVar reactorLifetime () + -- The set of requests ids that we have received but not finished processing pendingRequests <- newTVarIO Set.empty -- The set of requests that have been cancelled and are also in pendingRequests @@ -93,6 +106,7 @@ [ ideHandlers , cancelHandler cancelRequest , exitHandler exit + , shutdownHandler stopReactorLoop ] -- Cancel requests are special since they need to be handled -- out of order to be useful. Existing handlers are run afterwards. @@ -101,25 +115,23 @@ let serverDefinition = LSP.ServerDefinition { LSP.onConfigurationChange = onConfigurationChange , LSP.defaultConfig = defaultConfig - , LSP.doInitialize = handleInit exit clearReqId waitForCancel clientMsgChan + , LSP.doInitialize = handleInit reactorLifetime exit clearReqId waitForCancel clientMsgChan , LSP.staticHandlers = asyncHandlers , LSP.interpretHandler = \(env, st) -> LSP.Iso (LSP.runLspT env . flip runReaderT (clientMsgChan,st)) liftIO , LSP.options = modifyOptions options } - void $ waitAnyCancel =<< traverse async - [ void $ LSP.runServerWithHandles + void $ untilMVar clientMsgVar $ + void $ LSP.runServerWithHandles inH outH serverDefinition - , void $ readMVar clientMsgVar - ] where handleInit - :: IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage + :: MVar () -> IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage -> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) - handleInit exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do + handleInit lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do traceWithSpan sp params let root = LSP.resRootPath env dir <- maybe getCurrentDirectory return root @@ -128,70 +140,88 @@ -- The database needs to be open for the duration of the reactor thread, but we need to pass in a reference -- to 'getIdeState', so we use this dirty trick dbMVar <- newEmptyMVar - ~(hiedb,hieChan) <- unsafeInterleaveIO $ takeMVar dbMVar + ~(WithHieDbShield withHieDb,hieChan) <- unsafeInterleaveIO $ takeMVar dbMVar - ide <- getIdeState env (makeLSPVFSHandle env) root hiedb hieChan + ide <- getIdeState env (makeLSPVFSHandle env) root withHieDb hieChan let initConfig = parseConfiguration params logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig registerIdeConfiguration (shakeExtras ide) initConfig let handleServerException (Left e) = do - logError (ideLogger ide) $ + logError logger $ T.pack $ "Fatal error in server thread: " <> show e + sendErrorMessage e exitClientMsg - handleServerException _ = pure () + handleServerException (Right _) = pure () + + sendErrorMessage (e :: SomeException) = do + LSP.runLspT env $ LSP.sendNotification SWindowShowMessage $ + ShowMessageParams MtError $ T.unlines + [ "Unhandled exception, please [report](" <> issueTrackerUrl <> "): " + , T.pack(show e) + ] + + exceptionInHandler e = do + logError logger $ T.pack $ + "Unexpected exception, please report!\n" ++ + "Exception: " ++ show e + sendErrorMessage e + logger = ideLogger ide - _ <- flip forkFinally handleServerException $ runWithDb logger dbLoc $ \hiedb hieChan -> do - putMVar dbMVar (hiedb,hieChan) - forever $ do - msg <- readChan clientMsgChan - -- We dispatch notifications synchronously and requests asynchronously - -- This is to ensure that all file edits and config changes are applied before a request is handled - case msg of - ReactorNotification act -> do - catch act $ \(e :: SomeException) -> - logError (ideLogger ide) $ T.pack $ - "Unexpected exception on notification, please report!\n" ++ - "Exception: " ++ show e - ReactorRequest _id act k -> void $ async $ - checkCancelled ide clearReqId waitForCancel _id act k + + checkCancelled _id act k = + flip finally (clearReqId _id) $ + catch (do + -- We could optimize this by first checking if the id + -- is in the cancelled set. However, this is unlikely to be a + -- bottleneck and the additional check might hide + -- issues with async exceptions that need to be fixed. + cancelOrRes <- race (waitForCancel _id) act + case cancelOrRes of + Left () -> do + logDebug (ideLogger ide) $ T.pack $ "Cancelled request " <> show _id + k $ ResponseError RequestCancelled "" Nothing + Right res -> pure res + ) $ \(e :: SomeException) -> do + exceptionInHandler e + k $ ResponseError InternalError (T.pack $ show e) Nothing + _ <- flip forkFinally handleServerException $ do + untilMVar lifetime $ runWithDb logger dbLoc $ \withHieDb hieChan -> do + putMVar dbMVar (WithHieDbShield withHieDb,hieChan) + forever $ do + msg <- readChan clientMsgChan + -- We dispatch notifications synchronously and requests asynchronously + -- This is to ensure that all file edits and config changes are applied before a request is handled + case msg of + ReactorNotification act -> handle exceptionInHandler act + ReactorRequest _id act k -> void $ async $ checkCancelled _id act k + logInfo logger "Reactor thread stopped" pure $ Right (env,ide) - checkCancelled - :: IdeState -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> SomeLspId - -> IO () -> (ResponseError -> IO ()) -> IO () - checkCancelled ide clearReqId waitForCancel _id act k = - flip finally (clearReqId _id) $ - catch (do - -- We could optimize this by first checking if the id - -- is in the cancelled set. However, this is unlikely to be a - -- bottleneck and the additional check might hide - -- issues with async exceptions that need to be fixed. - cancelOrRes <- race (waitForCancel _id) act - case cancelOrRes of - Left () -> do - logDebug (ideLogger ide) $ T.pack $ "Cancelled request " <> show _id - k $ ResponseError RequestCancelled "" Nothing - Right res -> pure res - ) $ \(e :: SomeException) -> do - logError (ideLogger ide) $ T.pack $ - "Unexpected exception on request, please report!\n" ++ - "Exception: " ++ show e - k $ ResponseError InternalError (T.pack $ show e) Nothing +-- | Runs the action until it ends or until the given MVar is put. +-- Rethrows any exceptions. +untilMVar :: MonadUnliftIO m => MVar () -> m () -> m () +untilMVar mvar io = void $ + waitAnyCancel =<< traverse async [ io , readMVar mvar ] cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c) cancelHandler cancelRequest = LSP.notificationHandler SCancelRequest $ \NotificationMessage{_params=CancelParams{_id}} -> liftIO $ cancelRequest (SomeLspId _id) -exitHandler :: IO () -> LSP.Handlers (ServerM c) -exitHandler exit = LSP.notificationHandler SExit $ const $ do +shutdownHandler :: IO () -> LSP.Handlers (ServerM c) +shutdownHandler stopReactor = LSP.requestHandler SShutdown $ \_ resp -> do (_, ide) <- ask - liftIO $ logDebug (ideLogger ide) "Received exit message" + liftIO $ logDebug (ideLogger ide) "Received shutdown message" + -- stop the reactor to free up the hiedb connection + liftIO stopReactor -- flush out the Shake session to record a Shake profile if applicable liftIO $ shakeShut ide - liftIO exit + resp $ Right Empty + +exitHandler :: IO () -> LSP.Handlers (ServerM c) +exitHandler exit = LSP.notificationHandler SExit $ const $ liftIO exit modifyOptions :: LSP.Options -> LSP.Options modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS diff --git a/src/Development/IDE/LSP/Notifications.hs b/src/Development/IDE/LSP/Notifications.hs --- a/src/Development/IDE/LSP/Notifications.hs +++ b/src/Development/IDE/LSP/Notifications.hs @@ -14,6 +14,7 @@ import Language.LSP.Types import qualified Language.LSP.Types as LSP +import Control.Concurrent.STM.Stats (atomically) import Control.Monad.Extra import Control.Monad.IO.Class import qualified Data.HashMap.Strict as HM @@ -42,7 +43,7 @@ descriptor plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = mconcat [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $ \ide _ (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do - updatePositionMapping ide (VersionedTextDocumentIdentifier _uri (Just _version)) (List []) + atomically $ updatePositionMapping ide (VersionedTextDocumentIdentifier _uri (Just _version)) (List []) whenUriFile _uri $ \file -> do -- We don't know if the file actually exists, or if the contents match those on disk -- For example, vscode restores previously unsaved contents on open @@ -52,7 +53,7 @@ , mkPluginNotificationHandler LSP.STextDocumentDidChange $ \ide _ (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> liftIO $ do - updatePositionMapping ide identifier changes + atomically $ updatePositionMapping ide identifier changes whenUriFile _uri $ \file -> do addFileOfInterest ide file Modified{firstOpen=False} setFileModified ide False file diff --git a/src/Development/IDE/LSP/Outline.hs b/src/Development/IDE/LSP/Outline.hs --- a/src/Development/IDE/LSP/Outline.hs +++ b/src/Development/IDE/LSP/Outline.hs @@ -29,6 +29,9 @@ SymbolKind (SkConstructor, SkField, SkFile, SkFunction, SkInterface, SkMethod, SkModule, SkObject, SkStruct, SkTypeParameter, SkUnknown), TextDocumentIdentifier (TextDocumentIdentifier), type (|?) (InL), uriToFilePath) +#if MIN_VERSION_ghc(9,2,0) +import Data.List.NonEmpty (nonEmpty, toList) +#endif moduleOutline :: IdeState -> DocumentSymbolParams -> LspM c (Either ResponseError (List DocumentSymbol |? List SymbolInformation)) @@ -42,17 +45,11 @@ -> let declSymbols = mapMaybe documentSymbolForDecl hsmodDecls moduleSymbol = hsmodName >>= \case - (L (RealSrcSpan l _) m) -> Just $ + (L (locA -> (RealSrcSpan l _)) m) -> Just $ (defDocumentSymbol l :: DocumentSymbol) { _name = pprText m , _kind = SkFile - , _range = Range (Position 0 0) (Position 2147483647 0) -- _ltop is 0 0 0 0 - -- In the lsp spec from 3.16 Position takes a uinteger, - -- where uinteger is 0 - 2^31 - 1. lsp-types currently has the type of line - -- as Int. So instead of using `maxBound :: Int` we hardcode the maxBound of - -- uinteger. 2 ^ 31 - 1 == 2147483647 - -- Check this issue for tracking https://github.com/haskell/lsp/issues/354 - -- the change in lsp-types. + , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0 } _ -> Nothing importSymbols = maybe [] pure $ @@ -70,8 +67,8 @@ Nothing -> pure $ Right $ InL (List []) -documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol -documentSymbolForDecl (L (RealSrcSpan l _) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) +documentSymbolForDecl :: LHsDecl GhcPs -> Maybe DocumentSymbol +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n <> (case pprText fdTyVars of @@ -81,7 +78,7 @@ , _detail = Just $ pprText fdInfo , _kind = SkFunction } -documentSymbolForDecl (L (RealSrcSpan l _) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars })) +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName name <> (case pprText tcdTyVars of @@ -97,11 +94,11 @@ , _kind = SkMethod , _selectionRange = realSrcSpanToRange l' } - | L (RealSrcSpan l _) (ClassOpSig _ False names _) <- tcdSigs - , L (RealSrcSpan l' _) n <- names + | L (locA -> (RealSrcSpan l _)) (ClassOpSig _ False names _) <- tcdSigs + , L (locA -> (RealSrcSpan l' _)) n <- names ] } -documentSymbolForDecl (L (RealSrcSpan l _) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } })) +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName name , _kind = SkStruct @@ -111,13 +108,33 @@ { _name = showRdrName n , _kind = SkConstructor , _selectionRange = realSrcSpanToRange l' - , _children = conArgRecordFields (con_args x) +#if MIN_VERSION_ghc(9,2,0) + , _children = List . toList <$> nonEmpty childs } - | L (RealSrcSpan l _ ) x <- dd_cons - , L (RealSrcSpan l' _) n <- getConNames' x + | con <- dd_cons + , let (cs, flds) = hsConDeclsBinders con + , let childs = mapMaybe cvtFld flds + , L (locA -> RealSrcSpan l' _) n <- cs + , let l = case con of + L (locA -> RealSrcSpan l _) _ -> l + _ -> l' ] } where + cvtFld :: LFieldOcc GhcPs -> Maybe DocumentSymbol + cvtFld (L (RealSrcSpan l _) n) = Just $ (defDocumentSymbol l :: DocumentSymbol) + { _name = showRdrName (unLoc (rdrNameFieldOcc n)) + , _kind = SkField + } + cvtFld _ = Nothing +#else + , _children = conArgRecordFields (con_args x) + } + | L (locA -> (RealSrcSpan l _ )) x <- dd_cons + , L (locA -> (RealSrcSpan l' _)) n <- getConNames' x + ] + } + where -- | Extract the record fields of a constructor conArgRecordFields (RecCon (L _ lcdfs)) = Just $ List [ (defDocumentSymbol l :: DocumentSymbol) @@ -125,48 +142,57 @@ , _kind = SkField } | L _ cdf <- lcdfs - , L (RealSrcSpan l _) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf + , L (locA -> (RealSrcSpan l _)) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf ] conArgRecordFields _ = Nothing -documentSymbolForDecl (L (RealSrcSpan l _) (TyClD _ SynDecl { tcdLName = L (RealSrcSpan l' _) n })) = Just +#endif +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ SynDecl { tcdLName = L (locA -> (RealSrcSpan l' _)) n })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n , _kind = SkTypeParameter , _selectionRange = realSrcSpanToRange l' } -documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })) +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty , _kind = SkInterface } +#if MIN_VERSION_ghc(9,2,0) +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl FamEqn { feqn_tycon, feqn_pats } })) +#else documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) +#endif = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords (map pprText feqn_pats) , _kind = SkInterface } +#if MIN_VERSION_ghc(9,2,0) +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl _ FamEqn { feqn_tycon, feqn_pats } })) +#else documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) +#endif = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords (map pprText feqn_pats) , _kind = SkInterface } -documentSymbolForDecl (L (RealSrcSpan l _) (DerivD _ DerivDecl { deriv_type })) = +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (DerivD _ DerivDecl { deriv_type })) = gfindtype deriv_type <&> \(L (_ :: SrcSpan) name) -> (defDocumentSymbol l :: DocumentSymbol) { _name = pprText @(HsType GhcPs) name , _kind = SkInterface } -documentSymbolForDecl (L (RealSrcSpan l _) (ValD _ FunBind{fun_id = L _ name})) = Just +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ValD _ FunBind{fun_id = L _ name})) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName name , _kind = SkFunction } -documentSymbolForDecl (L (RealSrcSpan l _) (ValD _ PatBind{pat_lhs})) = Just +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ValD _ PatBind{pat_lhs})) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText pat_lhs , _kind = SkFunction } -documentSymbolForDecl (L (RealSrcSpan l _) (ForD _ x)) = Just +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ForD _ x)) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = case x of ForeignImport{} -> name @@ -199,8 +225,8 @@ , _children = Just (List importSymbols) } -documentSymbolForImport :: Located (ImportDecl GhcPs) -> Maybe DocumentSymbol -documentSymbolForImport (L (RealSrcSpan l _) ImportDecl { ideclName, ideclQualified }) = Just +documentSymbolForImport :: LImportDecl GhcPs -> Maybe DocumentSymbol +documentSymbolForImport (L (locA -> (RealSrcSpan l _)) ImportDecl { ideclName, ideclQualified }) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = "import " <> pprText ideclName , _kind = SkModule @@ -230,6 +256,7 @@ pprText = pack . showSDocUnsafe . ppr -- the version of getConNames for ghc9 is restricted to only the renaming phase +#if !MIN_VERSION_ghc(9,2,0) getConNames' :: ConDecl GhcPs -> [Located (IdP GhcPs)] getConNames' ConDeclH98 {con_name = name} = [name] getConNames' ConDeclGADT {con_names = names} = names @@ -237,4 +264,45 @@ getConNames' (XConDecl NoExt) = [] #elif !MIN_VERSION_ghc(9,0,0) getConNames' (XConDecl x) = noExtCon x +#endif +#else +hsConDeclsBinders :: LConDecl GhcPs + -> ([LIdP GhcPs], [LFieldOcc GhcPs]) + -- See hsLTyClDeclBinders for what this does + -- The function is boringly complicated because of the records + -- And since we only have equality, we have to be a little careful +hsConDeclsBinders cons + = go cons + where + go :: LConDecl GhcPs + -> ([LIdP GhcPs], [LFieldOcc GhcPs]) + go r + -- Don't re-mangle the location of field names, because we don't + -- have a record of the full location of the field declaration anyway + = case unLoc r of + -- remove only the first occurrence of any seen field in order to + -- avoid circumventing detection of duplicate fields (#9156) + ConDeclGADT { con_names = names, con_g_args = args } + -> (names, flds) + where + flds = get_flds_gadt args + + ConDeclH98 { con_name = name, con_args = args } + -> ([name], flds) + where + flds = get_flds_h98 args + + get_flds_h98 :: HsConDeclH98Details GhcPs + -> [LFieldOcc GhcPs] + get_flds_h98 (RecCon flds) = get_flds (reLoc flds) + get_flds_h98 _ = [] + + get_flds_gadt :: HsConDeclGADTDetails GhcPs + -> ([LFieldOcc GhcPs]) + get_flds_gadt (RecConGADT flds) = get_flds (reLoc flds) + get_flds_gadt _ = [] + + get_flds :: Located [LConDeclField GhcPs] + -> ([LFieldOcc GhcPs]) + get_flds flds = concatMap (cd_fld_names . unLoc) (unLoc flds) #endif diff --git a/src/Development/IDE/Main.hs b/src/Development/IDE/Main.hs --- a/src/Development/IDE/Main.hs +++ b/src/Development/IDE/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PackageImports #-} {-# OPTIONS_GHC -Wno-orphans #-} module Development.IDE.Main (Arguments(..) @@ -8,9 +9,10 @@ ,commandP ,defaultMain ,testing) where -import Control.Concurrent.Extra (newLock, readVar, - withLock, +import Control.Concurrent.Extra (newLock, withLock, withNumCapabilities) +import Control.Concurrent.STM.Stats (atomically, + dumpSTMStats) import Control.Exception.Safe (Exception (displayException), catchAny) import Control.Monad.Extra (concatMapM, unless, @@ -55,6 +57,7 @@ import Development.IDE.Core.Tracing (measureMemory) import Development.IDE.Graph (action) import Development.IDE.LSP.LanguageServer (runLanguageServer) +import Development.IDE.Main.HeapStats (withHeapStats) import Development.IDE.Plugin (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules)) import Development.IDE.Plugin.HLS (asGhcIdePlugin) import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide @@ -62,6 +65,7 @@ import Development.IDE.Session (SessionLoadingOptions, getHieDbLoc, loadSessionWithOptions, + retryOnSqliteBusy, runWithDb, setInitialDynFlags) import Development.IDE.Types.Location (NormalizedUri, @@ -98,8 +102,10 @@ PluginId (PluginId), ipMap) import qualified Language.LSP.Server as LSP +import qualified "list-t" ListT import Numeric.Natural (Natural) import Options.Applicative hiding (action) +import qualified StmContainers.Map as STM import qualified System.Directory.Extra as IO import System.Exit (ExitCode (ExitFailure), exitWith) @@ -111,18 +117,19 @@ hSetBuffering, hSetEncoding, stderr, stdin, stdout, utf8) +import System.Random (newStdGen) import System.Time.Extra (offsetTime, showDuration) import Text.Printf (printf) data Command = Check [FilePath] -- ^ Typecheck some paths and print diagnostics. Exit code is the number of failures - | Db {projectRoot :: FilePath, hieOptions :: HieDb.Options, hieCommand :: HieDb.Command} + | Db {hieOptions :: HieDb.Options, hieCommand :: HieDb.Command} -- ^ Run a command in the hiedb | LSP -- ^ Run the LSP server | PrintExtensionSchema | PrintDefaultConfig - | Custom {projectRoot :: FilePath, ideCommand :: IdeCommand IdeState} -- ^ User defined + | Custom {ideCommand :: IdeCommand IdeState} -- ^ User defined deriving Show @@ -137,7 +144,7 @@ commandP :: IdePlugins IdeState -> Parser Command commandP plugins = hsubparser(command "typecheck" (info (Check <$> fileCmd) fileInfo) - <> command "hiedb" (info (Db "." <$> HieDb.optParser "" True <*> HieDb.cmdParser <**> helper) hieInfo) + <> command "hiedb" (info (Db <$> HieDb.optParser "" True <*> HieDb.cmdParser <**> helper) hieInfo) <> command "lsp" (info (pure LSP <**> helper) lspInfo) <> command "vscode-extension-schema" extensionSchemaCommand <> command "generate-default-config" generateDefaultConfigCommand @@ -156,13 +163,14 @@ (fullDesc <> progDesc "Print config supported by the server with default values") pluginCommands = mconcat - [ command (T.unpack pId) (Custom "." <$> p) + [ command (T.unpack pId) (Custom <$> p) | (PluginId pId, PluginDescriptor{pluginCli = Just p}) <- ipMap plugins ] data Arguments = Arguments - { argsOTMemoryProfiling :: Bool + { argsProjectRoot :: Maybe FilePath + , argsOTMemoryProfiling :: Bool , argCommand :: Command , argsLogger :: IO Logger , argsRules :: Rules () @@ -184,7 +192,8 @@ defaultArguments :: Priority -> Arguments defaultArguments priority = Arguments - { argsOTMemoryProfiling = False + { argsProjectRoot = Nothing + , argsOTMemoryProfiling = False , argCommand = LSP , argsLogger = stderrLogger priority , argsRules = mainRule def >> action kick @@ -237,7 +246,9 @@ T.hPutStrLn stderr $ "[" <> T.pack (show p) <> "] " <> m defaultMain :: Arguments -> IO () -defaultMain Arguments{..} = do +defaultMain Arguments{..} = flip withHeapStats fun =<< argsLogger + where + fun = do setLocaleEncoding utf8 pid <- T.pack . show <$> getProcessID logger <- argsLogger @@ -265,7 +276,7 @@ t <- offsetTime logInfo logger "Starting LSP server..." logInfo logger "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!" - runLanguageServer options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath hiedb hieChan -> do + runLanguageServer options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath withHieDb hieChan -> do traverse_ IO.setCurrentDirectory rootPath t <- t logInfo logger $ T.pack $ "Started LSP server in " ++ showDuration t @@ -306,10 +317,11 @@ debouncer options vfs - hiedb + withHieDb hieChan + dumpSTMStats Check argFiles -> do - dir <- IO.getCurrentDirectory + dir <- maybe IO.getCurrentDirectory return argsProjectRoot dbLoc <- getHieDbLoc dir runWithDb logger dbLoc $ \hiedb hieChan -> do -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error @@ -357,31 +369,34 @@ putStrLn $ "\nCompleted (" ++ nfiles worked ++ " worked, " ++ nfiles failed ++ " failed)" when argsOTMemoryProfiling $ do - let valuesRef = state $ shakeExtras ide - values <- readVar valuesRef + let values = state $ shakeExtras ide let consoleObserver Nothing = return $ \size -> printf "Total: %.2fMB\n" (fromIntegral @Int @Double size / 1e6) consoleObserver (Just k) = return $ \size -> printf " - %s: %.2fKB\n" (show k) (fromIntegral @Int @Double size / 1e3) - printf "# Shake value store contents(%d):\n" (length values) + stateContents <- atomically $ ListT.toList $ STM.listT values + printf "# Shake value store contents(%d):\n" (length stateContents) let keys = nub $ typeOf GhcSession : typeOf GhcSessionDeps : - [kty | (fromKeyType -> Just (kty,_)) <- HashMap.keys values, kty /= typeOf GhcSessionIO] ++ + [kty | (fromKeyType -> Just (kty,_), _) <- stateContents, kty /= typeOf GhcSessionIO] ++ [typeOf GhcSessionIO] - measureMemory logger [keys] consoleObserver valuesRef + measureMemory logger [keys] consoleObserver values unless (null failed) (exitWith $ ExitFailure (length failed)) - Db dir opts cmd -> do - dbLoc <- getHieDbLoc dir + Db opts cmd -> do + root <- maybe IO.getCurrentDirectory return argsProjectRoot + dbLoc <- getHieDbLoc root hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc - mlibdir <- setInitialDynFlags logger dir def + mlibdir <- setInitialDynFlags logger root def + rng <- newStdGen case mlibdir of Nothing -> exitWith $ ExitFailure 1 - Just libdir -> HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd + Just libdir -> retryOnSqliteBusy logger rng (HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd) - Custom projectRoot (IdeCommand c) -> do - dbLoc <- getHieDbLoc projectRoot + Custom (IdeCommand c) -> do + root <- maybe IO.getCurrentDirectory return argsProjectRoot + dbLoc <- getHieDbLoc root runWithDb logger dbLoc $ \hiedb hieChan -> do vfs <- makeVFSHandle sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions "." diff --git a/src/Development/IDE/Main/HeapStats.hs b/src/Development/IDE/Main/HeapStats.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Main/HeapStats.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE NumericUnderscores #-} +-- | Logging utilities for reporting heap statistics +module Development.IDE.Main.HeapStats ( withHeapStats ) where + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Monad +import qualified Data.Text as T +import Data.Word +import Development.IDE.Types.Logger (Logger, logInfo) +import GHC.Stats +import Text.Printf (printf) + +-- | Interval at which to report the latest heap statistics. +heapStatsInterval :: Int +heapStatsInterval = 60_000_000 -- 60s + +-- | Report the live bytes and heap size at the last major collection. +logHeapStats :: Logger -> IO () +logHeapStats l = do + stats <- getRTSStats + -- live_bytes is the total amount of live memory in a program + -- (corresponding to the amount on a heap profile) + let live_bytes = gcdetails_live_bytes (gc stats) + -- heap_size is the total amount of memory the RTS is using + -- this corresponds closer to OS memory usage + heap_size = gcdetails_mem_in_use_bytes (gc stats) + format :: Word64 -> T.Text + format m = T.pack (printf "%.2fMB" (fromIntegral @Word64 @Double m / 1e6)) + message = "Live bytes: " <> format live_bytes <> " " <> + "Heap size: " <> format heap_size + logInfo l message + +-- | An action which logs heap statistics at the 'heapStatsInterval' +heapStatsThread :: Logger -> IO r +heapStatsThread l = forever $ do + threadDelay heapStatsInterval + logHeapStats l + +-- | A helper function which lauches the 'heapStatsThread' and kills it +-- appropiately when the inner action finishes. It also checks to see +-- if `-T` is enabled. +withHeapStats :: Logger -> IO r -> IO r +withHeapStats l k = do + enabled <- getRTSStatsEnabled + if enabled + then do + logInfo l ("Logging heap statistics every " + <> T.pack (printf "%.2fs" (fromIntegral @Int @Double heapStatsInterval / 1e6))) + withAsync (heapStatsThread l) (const k) + else do + logInfo l "Heap statistics are not enabled (RTS option -T is needed)" + k diff --git a/src/Development/IDE/Plugin/CodeAction.hs b/src/Development/IDE/Plugin/CodeAction.hs --- a/src/Development/IDE/Plugin/CodeAction.hs +++ b/src/Development/IDE/Plugin/CodeAction.hs @@ -3,6 +3,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} -- | Go to the definition of a variable. @@ -21,7 +22,9 @@ import Control.Applicative ((<|>)) import Control.Arrow (second, (>>>)) -import Control.Monad (guard, join) +import Control.Concurrent.STM.Stats (atomically) +import Control.Monad (guard, join, + msum) import Control.Monad.IO.Class import Data.Char import qualified Data.DList as DL @@ -44,8 +47,10 @@ import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Error +import Development.IDE.GHC.ExactPrint import Development.IDE.GHC.Util (prettyPrint, printRdrName, + traceAst, unsafePrintSDoc) import Development.IDE.Plugin.CodeAction.Args import Development.IDE.Plugin.CodeAction.ExactPrint @@ -70,6 +75,7 @@ SMethod (STextDocumentCodeAction), TextDocumentIdentifier (TextDocumentIdentifier), TextEdit (TextEdit), + UInt, WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges), type (|?) (InR), uriToFilePath) @@ -90,7 +96,7 @@ liftIO $ do let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents mbFile = toNormalizedFilePath' <$> uriToFilePath uri - diag <- fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state + diag <- atomically $ fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state (join -> parsedModule) <- runAction "GhcideCodeActions.getParsedModule" state $ getParsedModule `traverse` mbFile let actions = caRemoveRedundantImports parsedModule text diag xs uri @@ -139,7 +145,7 @@ ------------------------------------------------------------------------------------------------- -findSigOfDecl :: (IdP p -> Bool) -> [LHsDecl p] -> Maybe (Sig p) +findSigOfDecl :: p ~ GhcPass p0 => (IdP p -> Bool) -> [LHsDecl p] -> Maybe (Sig p) findSigOfDecl pred decls = listToMaybe [ sig @@ -147,7 +153,7 @@ any (pred . unLoc) idsSig ] -findSigOfDeclRanged :: Range -> [LHsDecl p] -> Maybe (Sig p) +findSigOfDeclRanged :: forall p p0 . p ~ GhcPass p0 => Range -> [LHsDecl p] -> Maybe (Sig p) findSigOfDeclRanged range decls = do dec <- findDeclContainingLoc (_start range) decls case dec of @@ -155,7 +161,7 @@ L _ (ValD _ (bind :: HsBind p)) -> findSigOfBind range bind _ -> Nothing -findSigOfBind :: Range -> HsBind p -> Maybe (Sig p) +findSigOfBind :: forall p p0. p ~ GhcPass p0 => Range -> HsBind p -> Maybe (Sig p) findSigOfBind range bind = case bind of FunBind {} -> findSigOfLMatch (unLoc $ mg_alts (fun_matches bind)) @@ -164,30 +170,38 @@ findSigOfLMatch :: [LMatch p (LHsExpr p)] -> Maybe (Sig p) findSigOfLMatch ls = do match <- findDeclContainingLoc (_start range) ls - findSigOfGRHSs (m_grhss (unLoc match)) - - findSigOfGRHSs :: GRHSs p (LHsExpr p) -> Maybe (Sig p) - findSigOfGRHSs grhs = do - if _start range `isInsideSrcSpan` (getLoc $ grhssLocalBinds grhs) + let grhs = m_grhss $ unLoc match +#if !MIN_VERSION_ghc(9,2,0) + span = getLoc $ reLoc $ grhssLocalBinds grhs + if _start range `isInsideSrcSpan` span then findSigOfBinds range (unLoc (grhssLocalBinds grhs)) -- where clause else do - grhs <- findDeclContainingLoc (_start range) (grhssGRHSs grhs) + grhs <- findDeclContainingLoc (_start range) (map reLocA $ grhssGRHSs grhs) case unLoc grhs of GRHS _ _ bd -> findSigOfExpr (unLoc bd) _ -> Nothing +#else + msum + [findSigOfBinds range (grhssLocalBinds grhs) -- where clause + , do + grhs <- findDeclContainingLoc (_start range) (map reLocA $ grhssGRHSs grhs) + case unLoc grhs of + GRHS _ _ bd -> findSigOfExpr (unLoc bd) + ] +#endif findSigOfExpr :: HsExpr p -> Maybe (Sig p) findSigOfExpr = go where - go (HsLet _ binds _) = findSigOfBinds range (unLoc binds) + go (HsLet _ binds _) = findSigOfBinds range binds go (HsDo _ _ stmts) = do stmtlr <- unLoc <$> findDeclContainingLoc (_start range) (unLoc stmts) case stmtlr of - LetStmt _ lhsLocalBindsLR -> findSigOfBinds range $ unLoc lhsLocalBindsLR - _ -> Nothing + LetStmt _ lhsLocalBindsLR -> findSigOfBinds range lhsLocalBindsLR + _ -> Nothing go _ = Nothing -findSigOfBinds :: Range -> HsLocalBinds p -> Maybe (Sig p) +findSigOfBinds :: p ~ GhcPass p0 => Range -> HsLocalBinds p -> Maybe (Sig p) findSigOfBinds range = go where go (HsValBinds _ (ValBinds _ binds lsigs)) = @@ -198,17 +212,27 @@ findSigOfBind range (unLoc lHsBindLR) go _ = Nothing -findInstanceHead :: (Outputable (HsType p)) => DynFlags -> String -> [LHsDecl p] -> Maybe (LHsType p) +findInstanceHead :: (Outputable (HsType p), p ~ GhcPass p0) => DynFlags -> String -> [LHsDecl p] -> Maybe (LHsType p) findInstanceHead df instanceHead decls = listToMaybe +#if !MIN_VERSION_ghc(9,2,0) [ hsib_body | L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = HsIB {hsib_body}})) <- decls, showSDoc df (ppr hsib_body) == instanceHead ] - -findDeclContainingLoc :: Position -> [Located a] -> Maybe (Located a) -findDeclContainingLoc loc = find (\(L l _) -> loc `isInsideSrcSpan` l) +#else + [ hsib_body + | L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = (unLoc -> HsSig {sig_body = hsib_body})})) <- decls, + showSDoc df (ppr hsib_body) == instanceHead + ] +#endif +#if MIN_VERSION_ghc(9,2,0) +findDeclContainingLoc :: Foldable t => Position -> t (GenLocated (SrcSpanAnn' a) e) -> Maybe (GenLocated (SrcSpanAnn' a) e) +#else +-- TODO populate this type signature for GHC versions <9.2 +#endif +findDeclContainingLoc loc = find (\(L l _) -> loc `isInsideSrcSpan` locA l) -- Single: -- This binding for ‘mod’ shadows the existing binding @@ -279,8 +303,8 @@ imv_name == mkModuleName modName, isTheSameLine imv_span importSpan ], - [GRE {..}] <- lookupGlobalRdrEnv rdrEnv occ, - importedIdentifier <- Right gre_name, + [GRE {gre_name = name}] <- lookupGlobalRdrEnv rdrEnv occ, + importedIdentifier <- Right name, refs <- M.lookup importedIdentifier refMap = maybe True (not . any (\(_, IdentifierDetails {..}) -> identInfo == S.singleton Use)) refs | otherwise = False @@ -289,7 +313,7 @@ suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range,..} -- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant | Just [_, bindings] <- matchRegexUnifySpaces _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant" - , Just (L _ impDecl) <- find (\(L l _) -> _start _range `isInsideSrcSpan` l && _end _range `isInsideSrcSpan` l ) hsmodImports + , Just (L _ impDecl) <- find (\(L (locA -> l) _) -> _start _range `isInsideSrcSpan` l && _end _range `isInsideSrcSpan` l ) hsmodImports , Just c <- contents , ranges <- map (rangesForBindingImport impDecl . T.unpack) (T.splitOn ", " bindings) , ranges' <- extendAllToIncludeCommaIfPossible False (indexedByPosition $ T.unpack c) (concat ranges) @@ -389,7 +413,7 @@ suggestRemoveRedundantExport ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..} | msg <- unifySpaces _message , Just export <- hsmodExports - , Just exportRange <- getLocatedRange export + , Just exportRange <- getLocatedRange $ reLoc export , exports <- unLoc export , Just (removeFromExport, !ranges) <- fmap (getRanges exports . notInScope) (extractNotInScopeName msg) <|> (,[_range]) <$> matchExportItem msg @@ -417,7 +441,7 @@ | otherwise = [] where relatedRanges indexedContent name = - concatMap (findRelatedSpans indexedContent name) hsmodDecls + concatMap (findRelatedSpans indexedContent name . reLoc) hsmodDecls toRange = realSrcSpanToRange extendForSpaces = extendToIncludePreviousNewlineIfPossible @@ -432,7 +456,7 @@ findSig _ = [] in extendForSpaces indexedContent (toRange l) : - concatMap findSig hsmodDecls + concatMap (findSig . reLoc) hsmodDecls _ -> concatMap (findRelatedSpanForMatch indexedContent name) matches findRelatedSpans _ _ _ = [] @@ -443,7 +467,7 @@ FunBind { fun_id=lname , fun_matches=MG {mg_alts=L _ matches} - } = Just (lname, matches) + } = Just (reLoc lname, matches) extractNameAndMatchesFromFunBind _ = Nothing findRelatedSigSpan :: PositionIndexedString -> String -> RealSrcSpan -> Sig GhcPs -> [Range] @@ -460,16 +484,16 @@ let maybeIdx = findIndex (\(L _ id) -> isSameName id name) lnames in case maybeIdx of Nothing -> Nothing - Just _ | length lnames == 1 -> Just (getLoc $ head lnames, True) + Just _ | length lnames == 1 -> Just (getLoc $ reLoc $ head lnames, True) Just idx -> - let targetLname = getLoc $ lnames !! idx + let targetLname = getLoc $ reLoc $ lnames !! idx startLoc = srcSpanStart targetLname endLoc = srcSpanEnd targetLname startLoc' = if idx == 0 then startLoc - else srcSpanEnd . getLoc $ lnames !! (idx - 1) + else srcSpanEnd . getLoc . reLoc $ lnames !! (idx - 1) endLoc' = if idx == 0 && idx < length lnames - 1 - then srcSpanStart . getLoc $ lnames !! (idx + 1) + then srcSpanStart . getLoc . reLoc $ lnames !! (idx + 1) else endLoc in Just (mkSrcSpan startLoc' endLoc', False) findRelatedSigSpan1 _ _ = Nothing @@ -484,12 +508,19 @@ indexedContent name (L _ Match{m_grhss=GRHSs{grhssLocalBinds}}) = do + let go bag lsigs = + if isEmptyBag bag + then [] + else concatMap (findRelatedSpanForHsBind indexedContent name lsigs) bag +#if !MIN_VERSION_ghc(9,2,0) case grhssLocalBinds of - (L _ (HsValBinds _ (ValBinds _ bag lsigs))) -> - if isEmptyBag bag - then [] - else concatMap (findRelatedSpanForHsBind indexedContent name lsigs) bag - _ -> [] + (L _ (HsValBinds _ (ValBinds _ bag lsigs))) -> go bag lsigs + _ -> [] +#else + case grhssLocalBinds of + (HsValBinds _ (ValBinds _ bag lsigs)) -> go bag lsigs + _ -> [] +#endif findRelatedSpanForMatch _ _ _ = [] findRelatedSpanForHsBind @@ -502,12 +533,12 @@ indexedContent name lsigs - (L (RealSrcSpan l _) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) = + (L (locA -> (RealSrcSpan l _)) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) = if isTheBinding (getLoc lname) then let findSig (L (RealSrcSpan l _) sig) = findRelatedSigSpan indexedContent name l sig findSig _ = [] - in extendForSpaces indexedContent (toRange l) : concatMap findSig lsigs + in extendForSpaces indexedContent (toRange l) : concatMap (findSig . reLoc) lsigs else concatMap (findRelatedSpanForMatch indexedContent name) matches findRelatedSpanForHsBind _ _ _ _ = [] @@ -517,7 +548,7 @@ isSameName :: IdP GhcPs -> String -> Bool isSameName x name = showSDocUnsafe (ppr x) == name -data ExportsAs = ExportName | ExportPattern | ExportAll +data ExportsAs = ExportName | ExportPattern | ExportFamily | ExportAll deriving (Eq) getLocatedRange :: Located a -> Maybe Range @@ -534,12 +565,12 @@ <|> matchRegexUnifySpaces _message ".*Defined but not used: data constructor ‘([^ ]+)’" , Just (exportType, _) <- find (matchWithDiagnostic _range . snd) . mapMaybe - (\(L l b) -> if maybe False isTopLevel $ srcSpanToRange l + (\(L (locA -> l) b) -> if maybe False isTopLevel $ srcSpanToRange l then exportsAs b else Nothing) $ hsmodDecls - , Just pos <- fmap _end . getLocatedRange =<< hsmodExports - , Just needComma <- needsComma source <$> hsmodExports - , let exportName = (if needComma then "," else "") <> printExport exportType name + , Just pos <- (fmap _end . getLocatedRange) . reLoc =<< hsmodExports + , Just needComma <- needsComma source <$> fmap reLoc hsmodExports + , let exportName = (if needComma then ", " else "") <> printExport exportType name insertPos = pos {_character = pred $ _character pos} = [("Export ‘" <> name <> "’", TextEdit (Range insertPos insertPos) exportName)] | otherwise = [] @@ -549,7 +580,7 @@ needsComma _ (L _ []) = False needsComma source (L (RealSrcSpan l _) exports) = let closeParan = _end $ realSrcSpanToRange l - lastExport = fmap _end . getLocatedRange $ last exports + lastExport = fmap _end . getLocatedRange $ last $ fmap reLoc exports in case lastExport of Just lastExport -> not $ T.isInfixOf "," $ textInRange (Range lastExport closeParan) source _ -> False @@ -571,18 +602,19 @@ printExport :: ExportsAs -> T.Text -> T.Text printExport ExportName x = parenthesizeIfNeeds False x printExport ExportPattern x = "pattern " <> x + printExport ExportFamily x = parenthesizeIfNeeds True x printExport ExportAll x = parenthesizeIfNeeds True x <> "(..)" isTopLevel :: Range -> Bool isTopLevel l = (_character . _start) l == 0 - exportsAs :: HsDecl p -> Maybe (ExportsAs, Located (IdP p)) - exportsAs (ValD _ FunBind {fun_id}) = Just (ExportName, fun_id) - exportsAs (ValD _ (PatSynBind _ PSB {psb_id})) = Just (ExportPattern, psb_id) - exportsAs (TyClD _ SynDecl{tcdLName}) = Just (ExportName, tcdLName) - exportsAs (TyClD _ DataDecl{tcdLName}) = Just (ExportAll, tcdLName) - exportsAs (TyClD _ ClassDecl{tcdLName}) = Just (ExportAll, tcdLName) - exportsAs (TyClD _ FamDecl{tcdFam}) = Just (ExportAll, fdLName tcdFam) + exportsAs :: HsDecl GhcPs -> Maybe (ExportsAs, Located (IdP GhcPs)) + exportsAs (ValD _ FunBind {fun_id}) = Just (ExportName, reLoc fun_id) + exportsAs (ValD _ (PatSynBind _ PSB {psb_id})) = Just (ExportPattern, reLoc psb_id) + exportsAs (TyClD _ SynDecl{tcdLName}) = Just (ExportName, reLoc tcdLName) + exportsAs (TyClD _ DataDecl{tcdLName}) = Just (ExportAll, reLoc tcdLName) + exportsAs (TyClD _ ClassDecl{tcdLName}) = Just (ExportAll, reLoc tcdLName) + exportsAs (TyClD _ FamDecl{tcdFam}) = Just (ExportFamily, reLoc $ fdLName tcdFam) exportsAs _ = Nothing suggestAddTypeAnnotationToSatisfyContraints :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] @@ -675,7 +707,7 @@ newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ | Range _ lastLineP : _ <- [ realSrcSpanToRange sp - | (L l@(RealSrcSpan sp _) _) <- hsmodDecls + | (L (locA -> l@(RealSrcSpan sp _)) _) <- hsmodDecls , _start `isInsideSrcSpan` l] , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0} = [ ("Define " <> sig @@ -699,18 +731,33 @@ = [("Use type signature: ‘" <> typeSignature <> "’", TextEdit _range typeSignature)] | otherwise = [] +{- Handles two variants with different formatting + +1. Could not find module ‘Data.Cha’ + Perhaps you meant Data.Char (from base-4.12.0.0) + +2. Could not find module ‘Data.I’ + Perhaps you meant + Data.Ix (from base-4.14.3.0) + Data.Eq (from base-4.14.3.0) + Data.Int (from base-4.14.3.0) +-} suggestModuleTypo :: Diagnostic -> [(T.Text, TextEdit)] suggestModuleTypo Diagnostic{_range=_range,..} --- src/Development/IDE/Core/Compile.hs:58:1: error: --- Could not find module ‘Data.Cha’ --- Perhaps you meant Data.Char (from base-4.12.0.0) - | "Could not find module" `T.isInfixOf` _message - , "Perhaps you meant" `T.isInfixOf` _message = let - findSuggestedModules = map (head . T.words) . drop 2 . T.lines - proposeModule mod = ("replace with " <> mod, TextEdit _range mod) - in map proposeModule $ nubOrd $ findSuggestedModules _message + | "Could not find module" `T.isInfixOf` _message = + case T.splitOn "Perhaps you meant" _message of + [_, stuff] -> + [ ("replace with " <> modul, TextEdit _range modul) + | modul <- mapMaybe extractModule (T.lines stuff) + ] + _ -> [] | otherwise = [] + where + extractModule line = case T.words line of + [modul, "(from", _] -> Just modul + _ -> Nothing + suggestFillHole :: Diagnostic -> [(T.Text, TextEdit)] suggestFillHole Diagnostic{_range=_range,..} | Just holeName <- extractHoleName _message @@ -847,12 +894,10 @@ Bool -- ^ Parenthesised? ModuleName - deriving (Show) data ModuleTarget = ExistingImp (NonEmpty (LImportDecl GhcPs)) | ImplicitPrelude [LImportDecl GhcPs] - deriving (Show) targetImports :: ModuleTarget -> [LImportDecl GhcPs] targetImports (ExistingImp ne) = NE.toList ne @@ -1005,13 +1050,13 @@ liftParseAST @(HsExpr GhcPs) df $ prettyPrint $ HsVar @GhcPs noExtField $ - L (mkGeneralSrcSpan "") rdr + reLocA $ L (mkGeneralSrcSpan "") rdr else Rewrite (rangeToSrcSpan "" _range) $ \df -> liftParseAST @RdrName df $ prettyPrint $ L (mkGeneralSrcSpan "") rdr ] findImportDeclByRange :: [LImportDecl GhcPs] -> Range -> Maybe (LImportDecl GhcPs) -findImportDeclByRange xs range = find (\(L l _)-> srcSpanToRange l == Just range) xs +findImportDeclByRange xs range = find (\(L (locA -> l) _)-> srcSpanToRange l == Just range) xs suggestFixConstructorImport :: Diagnostic -> [(T.Text, TextEdit)] suggestFixConstructorImport Diagnostic{_range=_range,..} @@ -1026,9 +1071,10 @@ = let fixedImport = typ <> "(" <> constructor <> ")" in [("Fix import of " <> fixedImport, TextEdit _range fixedImport)] | otherwise = [] + -- | Suggests a constraint for a declaration for which a constraint is missing. suggestConstraint :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)] -suggestConstraint df parsedModule diag@Diagnostic {..} +suggestConstraint df (makeDeltaAst -> parsedModule) diag@Diagnostic {..} | Just missingConstraint <- findMissingConstraint _message = let codeAction = if _message =~ ("the type signature for:" :: String) then suggestFunctionConstraint df parsedModule @@ -1073,14 +1119,18 @@ -- (Pair x x') == (Pair y y') = x == y && x' == y' | Just [instanceLineStr, constraintFirstCharStr] <- matchRegexUnifySpaces _message "bound by the instance declaration at .+:([0-9]+):([0-9]+)" +#if !MIN_VERSION_ghc(9,2,0) , Just (L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = HsIB{hsib_body}}))) +#else + , Just (L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = (unLoc -> HsSig{sig_body = hsib_body})}))) +#endif <- findDeclContainingLoc (Position (readPositionNumber instanceLineStr) (readPositionNumber constraintFirstCharStr)) hsmodDecls = Just hsib_body | otherwise = Nothing - readPositionNumber :: T.Text -> Int - readPositionNumber = T.unpack >>> read + readPositionNumber :: T.Text -> UInt + readPositionNumber = T.unpack >>> read @Integer >>> fromIntegral actionTitle :: T.Text -> T.Text actionTitle constraint = "Add `" <> constraint @@ -1093,7 +1143,12 @@ suggestImplicitParameter (L _ HsModule {hsmodDecls}) Diagnostic {_message, _range} | Just [implicitT] <- matchRegexUnifySpaces _message "Unbound implicit parameter \\(([^:]+::.+)\\) arising", Just (L _ (ValD _ FunBind {fun_id = L _ funId})) <- findDeclContainingLoc (_start _range) hsmodDecls, - Just (TypeSig _ _ HsWC {hswc_body = HsIB {hsib_body}}) <- findSigOfDecl (== funId) hsmodDecls +#if !MIN_VERSION_ghc(9,2,0) + Just (TypeSig _ _ HsWC {hswc_body = HsIB {hsib_body}}) +#else + Just (TypeSig _ _ HsWC {hswc_body = (unLoc -> HsSig {sig_body = hsib_body})}) +#endif + <- findSigOfDecl (== funId) hsmodDecls = [( "Add " <> implicitT <> " to the context of " <> T.pack (printRdrName funId) , appendConstraint (T.unpack implicitT) hsib_body)] @@ -1128,7 +1183,11 @@ -- In an equation for ‘eq’: -- eq (Pair x y) (Pair x' y') = x == x' && y == y' | Just typeSignatureName <- findTypeSignatureName _message +#if !MIN_VERSION_ghc(9,2,0) , Just (TypeSig _ _ HsWC{hswc_body = HsIB {hsib_body = sig}}) +#else + , Just (TypeSig _ _ HsWC{hswc_body = (unLoc -> HsSig {sig_body = sig})}) +#endif <- findSigOfDecl ((T.unpack typeSignatureName ==) . showSDoc df . ppr) hsmodDecls , title <- actionTitle missingConstraint typeSignatureName = [(title, appendConstraint (T.unpack missingConstraint) sig)] @@ -1151,8 +1210,12 @@ -- Account for both "Redundant constraint" and "Redundant constraints". | "Redundant constraint" `T.isInfixOf` _message , Just typeSignatureName <- findTypeSignatureName _message +#if !MIN_VERSION_ghc(9,2,0) , Just (TypeSig _ _ HsWC{hswc_body = HsIB {hsib_body = sig}}) - <- findSigOfDeclRanged _range hsmodDecls +#else + , Just (TypeSig _ _ HsWC{hswc_body = (unLoc -> HsSig {sig_body = sig})}) +#endif + <- fmap(traceAst "redundantConstraint") $ findSigOfDeclRanged _range hsmodDecls , Just redundantConstraintList <- findRedundantConstraints _message , rewrite <- removeConstraint (toRemove df redundantConstraintList) sig = [(actionTitle redundantConstraintList typeSignatureName, rewrite)] @@ -1171,12 +1234,23 @@ then constraints & T.drop 1 & T.dropEnd 1 & T.strip else constraints +{- +9.2: "message": "/private/var/folders/4m/d38fhm3936x_gy_9883zbq8h0000gn/T/extra-dir-53173393699/Testing.hs:4:1: warning: + ⢠Redundant constraints: (Eq a, Show a) + ⢠In the type signature for: + foo :: forall a. (Eq a, Show a) => a -> Bool", + +9.0: "message": "⢠Redundant constraints: (Eq a, Show a) + ⢠In the type signature for: + foo :: forall a. (Eq a, Show a) => a -> Bool", +-} findRedundantConstraints :: T.Text -> Maybe [T.Text] findRedundantConstraints t = t & T.lines - & head - & T.strip - & (`matchRegexUnifySpaces` "Redundant constraints?: (.+)") + -- In <9.2 it's the first line, in 9.2 it' the second line + & take 2 + & mapMaybe ((`matchRegexUnifySpaces` "Redundant constraints?: (.+)") . T.strip) + & listToMaybe <&> (head >>> parseConstraints) formatConstraints :: [T.Text] -> T.Text @@ -1289,9 +1363,10 @@ -- * otherwise inserted one line after the last file-header pragma newImportInsertRange :: ParsedSource -> T.Text -> Maybe (Range, Int) newImportInsertRange (L _ HsModule {..}) fileContents - | Just (uncurry Position -> insertPos, col) <- case hsmodImports of - [] -> findPositionNoImports hsmodName hsmodExports fileContents - _ -> findPositionFromImportsOrModuleDecl hsmodImports last True + | Just ((l, c), col) <- case hsmodImports of + [] -> findPositionNoImports (fmap reLoc hsmodName) (fmap reLoc hsmodExports) fileContents + _ -> findPositionFromImportsOrModuleDecl (map reLoc hsmodImports) last True + , let insertPos = Position (fromIntegral l) (fromIntegral c) = Just (Range insertPos insertPos, col) | otherwise = Nothing @@ -1489,7 +1564,7 @@ in if extend then Range _start (Position (_line _end + 1) 0) else range splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text) -splitTextAtPosition (Position row col) x +splitTextAtPosition (Position (fromIntegral -> row) (fromIntegral -> col)) x | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x , (preCol, postCol) <- T.splitAt col mid = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow) @@ -1497,7 +1572,7 @@ -- | Returns [start .. end[ textInRange :: Range -> T.Text -> T.Text -textInRange (Range (Position startRow startCol) (Position endRow endCol)) text = +textInRange (Range (Position (fromIntegral -> startRow) (fromIntegral -> startCol)) (Position (fromIntegral -> endRow) (fromIntegral -> endCol))) text = case compare startRow endRow of LT -> let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine @@ -1524,7 +1599,7 @@ wrapOperatorInParens :: String -> String wrapOperatorInParens x = case uncons x of - Just (h, _t) -> if isAlpha h then x else "(" <> x <> ")" + Just (h, _t) -> if is_ident h then x else "(" <> x <> ")" Nothing -> mempty smallerRangesForBindingExport :: [LIE GhcPs] -> String -> [Range] @@ -1533,22 +1608,35 @@ where unqualify = snd . breakOnEnd "." b' = wrapOperatorInParens . unqualify $ b +#if !MIN_VERSION_ghc(9,2,0) ranges' (L _ (IEThingWith _ thing _ inners labels)) | showSDocUnsafe (ppr thing) == b' = [] | otherwise = - [ l' | L l' x <- inners, showSDocUnsafe (ppr x) == b'] ++ - [ l' | L l' x <- labels, showSDocUnsafe (ppr x) == b'] + [ locA l' | L l' x <- inners, showSDocUnsafe (ppr x) == b'] + ++ [ l' | L l' x <- labels, showSDocUnsafe (ppr x) == b'] +#else + ranges' (L _ (IEThingWith _ thing _ inners)) + | showSDocUnsafe (ppr thing) == b' = [] + | otherwise = + [ locA l' | L l' x <- inners, showSDocUnsafe (ppr x) == b'] +#endif ranges' _ = [] rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan] -rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l] -rangesForBinding' b (L l x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l] -rangesForBinding' b (L l (IEThingAll _ x)) | showSDocUnsafe (ppr x) == b = [l] +rangesForBinding' b (L (locA -> l) x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l] +rangesForBinding' b (L (locA -> l) x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l] +rangesForBinding' b (L (locA -> l) (IEThingAll _ x)) | showSDocUnsafe (ppr x) == b = [l] +#if !MIN_VERSION_ghc(9,2,0) rangesForBinding' b (L l (IEThingWith _ thing _ inners labels)) +#else +rangesForBinding' b (L (locA -> l) (IEThingWith _ thing _ inners)) +#endif | showSDocUnsafe (ppr thing) == b = [l] | otherwise = - [ l' | L l' x <- inners, showSDocUnsafe (ppr x) == b] ++ - [ l' | L l' x <- labels, showSDocUnsafe (ppr x) == b] + [ locA l' | L l' x <- inners, showSDocUnsafe (ppr x) == b] +#if !MIN_VERSION_ghc(9,2,0) + ++ [ l' | L l' x <- labels, showSDocUnsafe (ppr x) == b] +#endif rangesForBinding' _ _ = [] -- | 'matchRegex' combined with 'unifySpaces' diff --git a/src/Development/IDE/Plugin/CodeAction/Args.hs b/src/Development/IDE/Plugin/CodeAction/Args.hs --- a/src/Development/IDE/Plugin/CodeAction/Args.hs +++ b/src/Development/IDE/Plugin/CodeAction/Args.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} module Development.IDE.Plugin.CodeAction.Args @@ -14,7 +15,7 @@ ) where -import Control.Concurrent.Extra +import Control.Concurrent.STM.Stats (readTVarIO) import Control.Monad.Reader import Control.Monad.Trans.Maybe import Data.Either (fromRight) @@ -54,12 +55,13 @@ runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext {_diagnostics = List diags}) codeAction = do let mbFile = toNormalizedFilePath' <$> uriToFilePath uri runRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure mbFile) >>= MaybeT . use key + caaGhcSession <- onceIO $ runRule GhcSession caaExportsMap <- onceIO $ - runRule GhcSession >>= \case + caaGhcSession >>= \case Just env -> do pkgExports <- envPackageExports env - localExports <- readVar (exportsMap $ shakeExtras state) + localExports <- readTVarIO (exportsMap $ shakeExtras state) pure $ localExports <> pkgExports _ -> pure mempty caaIdeOptions <- onceIO $ runAction "GhcideCodeActions.getIdeOptions" state getIdeOptions @@ -117,8 +119,12 @@ toTextEdit CodeActionArgs {..} rw = fmap (fromMaybe []) $ runMaybeT $ do df <- MaybeT caaDf +#if !MIN_VERSION_ghc(9,2,0) ps <- MaybeT caaAnnSource let r = rewriteToEdit df (annsA ps) rw +#else + let r = rewriteToEdit df rw +#endif pure $ fromRight [] r instance ToTextEdit a => ToTextEdit [a] where @@ -134,6 +140,7 @@ data CodeActionArgs = CodeActionArgs { caaExportsMap :: IO ExportsMap, + caaGhcSession :: IO (Maybe HscEnvEq), caaIdeOptions :: IO IdeOptions, caaParsedModule :: IO (Maybe ParsedModule), caaContents :: IO (Maybe T.Text), @@ -205,6 +212,7 @@ toCodeAction3 :: (ToCodeAction r) => (CodeActionArgs -> IO a) -> (a -> r) -> GhcideCodeAction toCodeAction3 get f = ReaderT $ \caa -> get caa >>= flip runReaderT caa . toCodeAction . f +-- | this instance returns a delta AST, useful for exactprint transforms instance ToCodeAction r => ToCodeAction (ParsedSource -> r) where toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaAnnSource = x} -> x >>= \case @@ -267,3 +275,9 @@ instance ToCodeAction r => ToCodeAction (GlobalBindingTypeSigsResult -> r) where toCodeAction = toCodeAction2 caaGblSigs + +instance ToCodeAction r => ToCodeAction (Maybe HscEnvEq -> r) where + toCodeAction = toCodeAction1 caaGhcSession + +instance ToCodeAction r => ToCodeAction (Maybe HscEnv -> r) where + toCodeAction = toCodeAction1 ((fmap.fmap.fmap) hscEnv caaGhcSession) diff --git a/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs --- a/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -2,12 +2,16 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} module Development.IDE.Plugin.CodeAction.ExactPrint ( Rewrite (..), rewriteToEdit, rewriteToWEdit, +#if !MIN_VERSION_ghc(9,2,0) transferAnn, +#endif -- * Utilities appendConstraint, @@ -30,16 +34,28 @@ mapMaybe) import qualified Data.Text as T import Development.IDE.GHC.Compat -import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Error -import Development.IDE.GHC.ExactPrint (ASTElement (parseAST), - Annotate) +import Development.IDE.GHC.ExactPrint import Development.IDE.Spans.Common import GHC.Exts (IsList (fromList)) import Language.Haskell.GHC.ExactPrint +#if !MIN_VERSION_ghc(9,2,0) +import qualified Development.IDE.GHC.Compat.Util as Util import Language.Haskell.GHC.ExactPrint.Types (DeltaPos (DP), KeywordId (G), mkAnnKey) +#else +import Data.Default +import GHC (AddEpAnn (..), AnnContext (..), AnnParen (..), + DeltaPos (SameLine), EpAnn (..), EpaLocation (EpaDelta), + IsUnicodeSyntax (NormalSyntax), + NameAdornment (NameParens), NameAnn (..), addAnns, ann, emptyComments, + reAnnL, AnnList (..)) +#endif import Language.LSP.Types +import Development.IDE.GHC.Util +import Data.Bifunctor (first) +import Control.Lens (_head, _last, over) +import GHC.Stack (HasCallStack) ------------------------------------------------------------------------------ @@ -47,35 +63,83 @@ -- given 'ast'. data Rewrite where Rewrite :: +#if !MIN_VERSION_ghc(9,2,0) Annotate ast => +#else + (ExactPrint (GenLocated (Anno ast) ast), ResetEntryDP (Anno ast), Outputable (GenLocated (Anno ast) ast), Data (GenLocated (Anno ast) ast)) => +#endif -- | The 'SrcSpan' that we want to rewrite SrcSpan -> -- | The ast that we want to graft +#if !MIN_VERSION_ghc(9,2,0) (DynFlags -> TransformT (Either String) (Located ast)) -> +#else + (DynFlags -> TransformT (Either String) (GenLocated (Anno ast) ast)) -> +#endif Rewrite ------------------------------------------------------------------------------ +#if MIN_VERSION_ghc(9,2,0) +class ResetEntryDP ann where + resetEntryDP :: GenLocated ann ast -> GenLocated ann ast +instance {-# OVERLAPPING #-} Default an => ResetEntryDP (SrcAnn an) where + -- resetEntryDP = flip setEntryDP (SameLine 0) + resetEntryDP (L srcAnn x) = setEntryDP (L srcAnn{ann=EpAnnNotUsed} x) (SameLine 0) +instance {-# OVERLAPPABLE #-} ResetEntryDP fallback where + resetEntryDP = id +#endif -- | Convert a 'Rewrite' into a list of '[TextEdit]'. -rewriteToEdit :: +rewriteToEdit :: HasCallStack => DynFlags -> +#if !MIN_VERSION_ghc(9,2,0) Anns -> +#endif Rewrite -> Either String [TextEdit] -rewriteToEdit dflags anns (Rewrite dst f) = do - (ast, (anns, _), _) <- runTransformT anns $ do +rewriteToEdit dflags +#if !MIN_VERSION_ghc(9,2,0) + anns +#endif + (Rewrite dst f) = do + (ast, anns , _) <- runTransformT +#if !MIN_VERSION_ghc(9,2,0) + anns +#endif + $ do ast <- f dflags +#if !MIN_VERSION_ghc(9,2,0) ast <$ setEntryDPT ast (DP (0, 0)) +#else + pure $ traceAst "REWRITE_result" $ resetEntryDP ast +#endif let editMap = [ TextEdit (fromJust $ srcSpanToRange dst) $ - T.pack $ exactPrint ast anns + T.pack $ exactPrint ast +#if !MIN_VERSION_ghc(9,2,0) + (fst anns) +#endif ] pure editMap -- | Convert a 'Rewrite' into a 'WorkspaceEdit' -rewriteToWEdit :: DynFlags -> Uri -> Anns -> Rewrite -> Either String WorkspaceEdit -rewriteToWEdit dflags uri anns r = do - edits <- rewriteToEdit dflags anns r +rewriteToWEdit :: DynFlags + -> Uri +#if !MIN_VERSION_ghc(9,2,0) + -> Anns +#endif + -> Rewrite + -> Either String WorkspaceEdit +rewriteToWEdit dflags uri +#if !MIN_VERSION_ghc(9,2,0) + anns +#endif + r = do + edits <- rewriteToEdit dflags +#if !MIN_VERSION_ghc(9,2,0) + anns +#endif + r return $ WorkspaceEdit { _changes = Just (fromList [(uri, List edits)]) @@ -85,16 +149,20 @@ ------------------------------------------------------------------------------ +#if !MIN_VERSION_ghc(9,2,0) -- | Fix the parentheses around a type context fixParens :: - (Monad m, Data (HsType pass)) => + (Monad m, Data (HsType pass), pass ~ GhcPass p0) => Maybe DeltaPos -> Maybe DeltaPos -> LHsContext pass -> TransformT m [LHsType pass] -fixParens openDP closeDP ctxt@(L _ elems) = do +fixParens + openDP closeDP + ctxt@(L _ elems) = do -- Paren annotation for type contexts are usually quite screwed up -- we remove duplicates and fix negative DPs + let parens = Map.fromList [(G AnnOpenP, dp00), (G AnnCloseP, dp00)] modifyAnnsT $ Map.adjust ( \x -> @@ -109,28 +177,44 @@ ) (mkAnnKey ctxt) return $ map dropHsParTy elems - where - parens = Map.fromList [(G AnnOpenP, dp00), (G AnnCloseP, dp00)] +#endif - dropHsParTy :: LHsType pass -> LHsType pass - dropHsParTy (L _ (HsParTy _ ty)) = ty - dropHsParTy other = other +dropHsParTy :: LHsType (GhcPass pass) -> LHsType (GhcPass pass) +dropHsParTy (L _ (HsParTy _ ty)) = ty +dropHsParTy other = other removeConstraint :: -- | Predicate: Which context to drop. (LHsType GhcPs -> Bool) -> LHsType GhcPs -> Rewrite -removeConstraint toRemove = go +removeConstraint toRemove = go . traceAst "REMOVE_CONSTRAINT_input" where - go (L l it@HsQualTy{hst_ctxt = L l' ctxt, hst_body}) = Rewrite l $ \_ -> do - let ctxt' = L l' $ filter (not . toRemove) ctxt - when ((toRemove <$> headMaybe ctxt) == Just True) $ + go :: LHsType GhcPs -> Rewrite +#if !MIN_VERSION_ghc(9,2,0) + go (L l it@HsQualTy{hst_ctxt = L l' ctxt, hst_body}) = Rewrite (locA l) $ \_ -> do +#else + go (L l it@HsQualTy{hst_ctxt = Just (L l' ctxt), hst_body}) = Rewrite (locA l) $ \_ -> do +#endif + let ctxt' = filter (not . toRemove) ctxt + removeStuff = (toRemove <$> headMaybe ctxt) == Just True +#if !MIN_VERSION_ghc(9,2,0) + when removeStuff $ setEntryDPT hst_body (DP (0, 0)) - return $ L l $ it{hst_ctxt = ctxt'} + return $ L l $ it{hst_ctxt = L l' ctxt'} +#else + let hst_body' = if removeStuff then resetEntryDP hst_body else hst_body + return $ case ctxt' of + [] -> hst_body' + _ -> do + let ctxt'' = over _last (first removeComma) ctxt' + L l $ it{ hst_ctxt = Just $ L l' ctxt'' + , hst_body = hst_body' + } +#endif go (L _ (HsParTy _ ty)) = go ty go (L _ HsForAllTy{hst_body}) = go hst_body - go (L l other) = Rewrite l $ \_ -> return $ L l other + go (L l other) = Rewrite (locA l) $ \_ -> return $ L l other -- | Append a constraint at the end of a type context. -- If no context is present, a new one will be created. @@ -140,30 +224,47 @@ -- | The type signature where the constraint is to be inserted, also assuming annotated LHsType GhcPs -> Rewrite -appendConstraint constraintT = go +appendConstraint constraintT = go . traceAst "appendConstraint" where - go (L l it@HsQualTy{hst_ctxt = L l' ctxt}) = Rewrite l $ \df -> do +#if !MIN_VERSION_ghc(9,2,0) + go (L l it@HsQualTy{hst_ctxt = L l' ctxt}) = Rewrite (locA l) $ \df -> do +#else + go (L l it@HsQualTy{hst_ctxt = Just (L l' ctxt)}) = Rewrite (locA l) $ \df -> do +#endif constraint <- liftParseAST df constraintT +#if !MIN_VERSION_ghc(9,2,0) setEntryDPT constraint (DP (0, 1)) -- Paren annotations are usually attached to the first and last constraints, -- rather than to the constraint list itself, so to preserve them we need to reposition them closeParenDP <- lookupAnn (G AnnCloseP) `mapM` lastMaybe ctxt openParenDP <- lookupAnn (G AnnOpenP) `mapM` headMaybe ctxt - ctxt' <- fixParens (join openParenDP) (join closeParenDP) (L l' ctxt) - + ctxt' <- fixParens + (join openParenDP) (join closeParenDP) + (L l' ctxt) addTrailingCommaT (last ctxt') - return $ L l $ it{hst_ctxt = L l' $ ctxt' ++ [constraint]} +#else + constraint <- pure $ setEntryDP constraint (SameLine 1) + let l'' = (fmap.fmap) (addParensToCtxt close_dp) l' + -- For singleton constraints, the close Paren DP is attached to an HsPar wrapping the constraint + -- we have to reposition it manually into the AnnContext + close_dp = case ctxt of + [L _ (HsParTy EpAnn{anns=AnnParen{ap_close}} _)] -> Just ap_close + _ -> Nothing + ctxt' = over _last (first addComma) $ map dropHsParTy ctxt + return $ L l $ it{hst_ctxt = Just $ L l'' $ ctxt' ++ [constraint]} +#endif go (L _ HsForAllTy{hst_body}) = go hst_body go (L _ (HsParTy _ ty)) = go ty - go (L l other) = Rewrite l $ \df -> do + go ast@(L l _) = Rewrite (locA l) $ \df -> do -- there isn't a context, so we must create one constraint <- liftParseAST df constraintT lContext <- uniqueSrcSpanT lTop <- uniqueSrcSpanT +#if !MIN_VERSION_ghc(9,2,0) let context = L lContext [constraint] - addSimpleAnnT context (DP (0, 0)) $ + addSimpleAnnT context dp00 $ (G AnnDarrow, DP (0, 1)) : concat [ [ (G AnnOpenP, dp00) @@ -171,14 +272,29 @@ ] | hsTypeNeedsParens sigPrec $ unLoc constraint ] - return $ L lTop $ HsQualTy noExtField context (L l other) +#else + let context = Just $ reAnnL annCtxt emptyComments $ L lContext [resetEntryDP constraint] + annCtxt = AnnContext (Just (NormalSyntax, epl 1)) [epl 0 | needsParens] [epl 0 | needsParens] + needsParens = hsTypeNeedsParens sigPrec $ unLoc constraint + ast <- pure $ setEntryDP ast (SameLine 1) +#endif -liftParseAST :: ASTElement ast => DynFlags -> String -> TransformT (Either String) (Located ast) + return $ reLocA $ L lTop $ HsQualTy noExtField context ast + +liftParseAST + :: forall ast l. (ASTElement l ast, ExactPrint (LocatedAn l ast)) + => DynFlags -> String -> TransformT (Either String) (LocatedAn l ast) liftParseAST df s = case parseAST df "" s of +#if !MIN_VERSION_ghc(9,2,0) Right (anns, x) -> modifyAnnsT (anns <>) $> x +#else + Right x -> pure (makeDeltaAst x) +#endif Left _ -> lift $ Left $ "No parse: " <> s -lookupAnn :: (Data a, Monad m) => KeywordId -> Located a -> TransformT m (Maybe DeltaPos) +#if !MIN_VERSION_ghc(9,2,0) +lookupAnn :: (Data a, Monad m) + => KeywordId -> Located a -> TransformT m (Maybe DeltaPos) lookupAnn comment la = do anns <- getAnnsT return $ Map.lookup (mkAnnKey la) anns >>= lookup comment . annsDP @@ -186,6 +302,17 @@ dp00 :: DeltaPos dp00 = DP (0, 0) +-- | Copy anns attached to a into b with modification, then delete anns of a +transferAnn :: (Data a, Data b) => Located a -> Located b -> (Annotation -> Annotation) -> TransformT (Either String) () +transferAnn la lb f = do + anns <- getAnnsT + let oldKey = mkAnnKey la + newKey = mkAnnKey lb + oldValue <- liftMaybe "Unable to find ann" $ Map.lookup oldKey anns + putAnnsT $ Map.delete oldKey $ Map.insert newKey (f oldValue) anns + +#endif + headMaybe :: [a] -> Maybe a headMaybe [] = Nothing headMaybe (a : _) = Just a @@ -198,24 +325,15 @@ liftMaybe _ (Just x) = return x liftMaybe s _ = lift $ Left s --- | Copy anns attached to a into b with modification, then delete anns of a -transferAnn :: (Data a, Data b) => Located a -> Located b -> (Annotation -> Annotation) -> TransformT (Either String) () -transferAnn la lb f = do - anns <- getAnnsT - let oldKey = mkAnnKey la - newKey = mkAnnKey lb - oldValue <- liftMaybe "Unable to find ann" $ Map.lookup oldKey anns - putAnnsT $ Map.delete oldKey $ Map.insert newKey (f oldValue) anns - ------------------------------------------------------------------------------ extendImport :: Maybe String -> String -> LImportDecl GhcPs -> Rewrite extendImport mparent identifier lDecl@(L l _) = - Rewrite l $ \df -> do + Rewrite (locA l) $ \df -> do case mparent of Just parent -> extendImportViaParent df parent identifier lDecl _ -> extendImportTopLevel identifier lDecl --- | Add an identifier or a data type to import list +-- | Add an identifier or a data type to import list. Expects a Delta AST -- -- extendImportTopLevel "foo" AST: -- @@ -232,19 +350,20 @@ , hasSibling <- not $ null lies = do src <- uniqueSrcSpanT top <- uniqueSrcSpanT - let rdr = L src $ mkRdrUnqual $ mkVarOcc thing - + let rdr = reLocA $ L src $ mkRdrUnqual $ mkVarOcc thing let alreadyImported = showNameWithoutUniques (occName (unLoc rdr)) `elem` map (showNameWithoutUniques @OccName) (listify (const True) lies) when alreadyImported $ lift (Left $ thing <> " already imported") - let lie = L src $ IEName rdr - x = L top $ IEVar noExtField lie + let lie = reLocA $ L src $ IEName rdr + x = reLocA $ L top $ IEVar noExtField lie + if x `elem` lies then lift (Left $ thing <> " already imported") else do +#if !MIN_VERSION_ghc(9,2,0) when hasSibling $ addTrailingCommaT (last lies) addSimpleAnnT x (DP (0, if hasSibling then 1 else 0)) [] @@ -254,6 +373,14 @@ unless hasSibling $ transferAnn (L l' lies) (L l' [x]) id return $ L l it{ideclHiding = Just (hide, L l' $ lies ++ [x])} +#else + + x <- pure $ setEntryDP x (SameLine $ if hasSibling then 1 else 0) + + let fixLast = if hasSibling then first addComma else id + lies' = over _last fixLast lies ++ [x] + return $ L l it{ideclHiding = Just (hide, L l' lies')} +#endif extendImportTopLevel _ _ = lift $ Left "Unable to extend the import list" -- | Add an identifier with its parent to import list @@ -277,39 +404,58 @@ extendImportViaParent df parent child (L l it@ImportDecl{..}) | Just (hide, L l' lies) <- ideclHiding = go hide l' [] lies where - go :: Bool -> SrcSpan -> [LIE GhcPs] -> [LIE GhcPs] -> TransformT (Either String) (LImportDecl GhcPs) go _hide _l' _pre ((L _ll' (IEThingAll _ (L _ ie))) : _xs) | parent == unIEWrappedName ie = lift . Left $ child <> " already included in " <> parent <> " imports" go hide l' pre (lAbs@(L ll' (IEThingAbs _ absIE@(L _ ie))) : xs) -- ThingAbs ie => ThingWith ie child | parent == unIEWrappedName ie = do srcChild <- uniqueSrcSpanT - let childRdr = L srcChild $ mkRdrUnqual $ mkVarOcc child - childLIE = L srcChild $ IEName childRdr + let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child + childLIE = reLocA $ L srcChild $ IEName childRdr +#if !MIN_VERSION_ghc(9,2,0) x :: LIE GhcPs = L ll' $ IEThingWith noExtField absIE NoIEWildcard [childLIE] [] -- take anns from ThingAbs, and attatch parens to it transferAnn lAbs x $ \old -> old{annsDP = annsDP old ++ [(G AnnOpenP, DP (0, 1)), (G AnnCloseP, dp00)]} addSimpleAnnT childRdr dp00 [(G AnnVal, dp00)] +#else + x :: LIE GhcPs = L ll' $ IEThingWith (addAnns mempty [AddEpAnn AnnOpenP (EpaDelta (SameLine 1) []), AddEpAnn AnnCloseP def] emptyComments) absIE NoIEWildcard [childLIE] +#endif return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [x] ++ xs)} +#if !MIN_VERSION_ghc(9,2,0) go hide l' pre ((L l'' (IEThingWith _ twIE@(L _ ie) _ lies' _)) : xs) +#else + go hide l' pre ((L l'' (IEThingWith l''' twIE@(L _ ie) _ lies')) : xs) +#endif -- ThingWith ie lies' => ThingWith ie (lies' ++ [child]) | parent == unIEWrappedName ie - , hasSibling <- not $ null lies' = + , hasSibling <- not $ null lies' = do srcChild <- uniqueSrcSpanT - let childRdr = L srcChild $ mkRdrUnqual $ mkVarOcc child - + let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child +#if MIN_VERSION_ghc(9,2,0) + childRdr <- pure $ setEntryDP childRdr $ SameLine $ if hasSibling then 1 else 0 +#endif let alreadyImported = showNameWithoutUniques (occName (unLoc childRdr)) `elem` map (showNameWithoutUniques @OccName) (listify (const True) lies') when alreadyImported $ lift (Left $ child <> " already included in " <> parent <> " imports") + let childLIE = reLocA $ L srcChild $ IEName childRdr +#if !MIN_VERSION_ghc(9,2,0) when hasSibling $ addTrailingCommaT (last lies') - let childLIE = L srcChild $ IEName childRdr addSimpleAnnT childRdr (DP (0, if hasSibling then 1 else 0)) [(G AnnVal, dp00)] return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [L l'' (IEThingWith noExtField twIE NoIEWildcard (lies' ++ [childLIE]) [])] ++ xs)} +#else + let it' = it{ideclHiding = Just (hide, lies)} + lies = L l' $ reverse pre ++ + [L l'' (IEThingWith l''' twIE NoIEWildcard (over _last fixLast lies' ++ [childLIE]))] ++ xs + fixLast = if hasSibling then first addComma else id + return $ if hasSibling + then L l it' + else L l it' +#endif go hide l' pre (x : xs) = go hide l' (x : pre) xs go hide l' pre [] | hasSibling <- not $ null pre = do @@ -318,13 +464,22 @@ srcParent <- uniqueSrcSpanT srcChild <- uniqueSrcSpanT parentRdr <- liftParseAST df parent - let childRdr = L srcChild $ mkRdrUnqual $ mkVarOcc child + let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child isParentOperator = hasParen parent +#if !MIN_VERSION_ghc(9,2,0) when hasSibling $ addTrailingCommaT (head pre) - let parentLIE = L srcParent $ (if isParentOperator then IEType else IEName) parentRdr - childLIE = L srcChild $ IEName childRdr - x :: LIE GhcPs = L l'' $ IEThingWith noExtField parentLIE NoIEWildcard [childLIE] [] + let parentLIE = L srcParent (if isParentOperator then IEType parentRdr else IEName parentRdr) + childLIE = reLocA $ L srcChild $ IEName childRdr +#else + let parentLIE = reLocA $ L srcParent $ (if isParentOperator then IEType (epl 0) parentRdr' else IEName parentRdr') + parentRdr' = modifyAnns parentRdr $ \case + it@NameAnn{nann_adornment = NameParens} -> it{nann_open = epl 1} + other -> other + childLIE = reLocA $ L srcChild $ IEName childRdr +#endif +#if !MIN_VERSION_ghc(9,2,0) + x :: LIE GhcPs = reLocA $ L l'' $ IEThingWith noExtField parentLIE NoIEWildcard [childLIE] [] -- Add AnnType for the parent if it's parenthesized (type operator) when isParentOperator $ addSimpleAnnT parentLIE (DP (0, 0)) [(G AnnType, DP (0, 0))] @@ -335,6 +490,10 @@ -- we need change the ann key from `[]` to `:` to keep parens and other anns. unless hasSibling $ transferAnn (L l' $ reverse pre) (L l' [x]) id +#else + x :: LIE GhcPs = reLocA $ L l'' $ IEThingWith listAnn parentLIE NoIEWildcard [childLIE] + listAnn = epAnn srcParent [AddEpAnn AnnOpenP (epl 1), AddEpAnn AnnCloseP (epl 0)] +#endif return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [x])} extendImportViaParent _ _ _ _ = lift $ Left "Unable to extend the import list via parent" @@ -345,6 +504,7 @@ hasParen ('(' : _) = True hasParen _ = False +#if !MIN_VERSION_ghc(9,2,0) unqalDP :: Int -> Bool -> [(KeywordId, DeltaPos)] unqalDP c paren = ( if paren @@ -352,6 +512,7 @@ else pure ) (G AnnVal, dp00) +#endif ------------------------------------------------------------------------------ @@ -360,28 +521,52 @@ String -> LImportDecl GhcPs -> Rewrite hideSymbol symbol lidecl@(L loc ImportDecl{..}) = case ideclHiding of - Nothing -> Rewrite loc $ extendHiding symbol lidecl Nothing - Just (True, hides) -> Rewrite loc $ extendHiding symbol lidecl (Just hides) - Just (False, imports) -> Rewrite loc $ deleteFromImport symbol lidecl imports + Nothing -> Rewrite (locA loc) $ extendHiding symbol lidecl Nothing + Just (True, hides) -> Rewrite (locA loc) $ extendHiding symbol lidecl (Just hides) + Just (False, imports) -> Rewrite (locA loc) $ deleteFromImport symbol lidecl imports hideSymbol _ (L _ (XImportDecl _)) = error "cannot happen" extendHiding :: String -> LImportDecl GhcPs -> +#if !MIN_VERSION_ghc(9,2,0) Maybe (Located [LIE GhcPs]) -> +#else + Maybe (XRec GhcPs [LIE GhcPs]) -> +#endif DynFlags -> TransformT (Either String) (LImportDecl GhcPs) extendHiding symbol (L l idecls) mlies df = do L l' lies <- case mlies of +#if !MIN_VERSION_ghc(9,2,0) Nothing -> flip L [] <$> uniqueSrcSpanT +#else + Nothing -> do + src <- uniqueSrcSpanT + let ann = noAnnSrcSpanDP0 src + ann' = flip (fmap.fmap) ann $ \x -> x + {al_rest = [AddEpAnn AnnHiding (epl 1)] + ,al_open = Just $ AddEpAnn AnnOpenP (epl 1) + ,al_close = Just $ AddEpAnn AnnCloseP (epl 0) + } + return $ L ann' [] +#endif Just pr -> pure pr let hasSibling = not $ null lies src <- uniqueSrcSpanT top <- uniqueSrcSpanT rdr <- liftParseAST df symbol - let lie = L src $ IEName rdr - x = L top $ IEVar noExtField lie +#if MIN_VERSION_ghc(9,2,0) + rdr <- pure $ modifyAnns rdr $ addParens (isOperator $ unLoc rdr) +#endif + let lie = reLocA $ L src $ IEName rdr + x = reLocA $ L top $ IEVar noExtField lie +#if MIN_VERSION_ghc(9,2,0) + x <- pure $ if hasSibling then first addComma x else x + lies <- pure $ over _head (`setEntryDP` SameLine 1) lies +#endif +#if !MIN_VERSION_ghc(9,2,0) singleHide = L l' [x] when (isNothing mlies) $ do addSimpleAnnT @@ -394,13 +579,14 @@ addSimpleAnnT x (DP (0, 0)) [] addSimpleAnnT rdr dp00 $ unqalDP 0 $ isOperator $ unLoc rdr if hasSibling - then when hasSibling $ do + then do addTrailingCommaT x addSimpleAnnT (head lies) (DP (0, 1)) [] unless (null $ tail lies) $ addTrailingCommaT (head lies) -- Why we need this? else forM_ mlies $ \lies0 -> do transferAnn lies0 singleHide id +#endif return $ L l idecls{ideclHiding = Just (True, L l' $ x : lies)} where isOperator = not . all isAlphaNum . occNameString . rdrNameOcc @@ -408,7 +594,11 @@ deleteFromImport :: String -> LImportDecl GhcPs -> +#if !MIN_VERSION_ghc(9,2,0) Located [LIE GhcPs] -> +#else + XRec GhcPs [LIE GhcPs] -> +#endif DynFlags -> TransformT (Either String) (LImportDecl GhcPs) deleteFromImport (T.pack -> symbol) (L l idecl) llies@(L lieLoc lies) _ = do @@ -418,6 +608,7 @@ idecl { ideclHiding = Just (False, edited) } +#if !MIN_VERSION_ghc(9,2,0) -- avoid import A (foo,) whenJust (lastMaybe deletedLies) removeTrailingCommaT when (not (null lies) && null deletedLies) $ do @@ -428,9 +619,13 @@ [ (G AnnOpenP, DP (0, 1)) , (G AnnCloseP, DP (0, 0)) ] +#endif pure lidecl' where deletedLies = +#if MIN_VERSION_ghc(9,2,0) + over _last removeTrailingComma $ +#endif mapMaybe killLie lies killLie :: LIE GhcPs -> Maybe (LIE GhcPs) killLie v@(L _ (IEVar _ (L _ (unqualIEWrapName -> nam)))) @@ -439,7 +634,11 @@ killLie v@(L _ (IEThingAbs _ (L _ (unqualIEWrapName -> nam)))) | nam == symbol = Nothing | otherwise = Just v +#if !MIN_VERSION_ghc(9,2,0) killLie (L lieL (IEThingWith xt ty@(L _ (unqualIEWrapName -> nam)) wild cons flds)) +#else + killLie (L lieL (IEThingWith xt ty@(L _ (unqualIEWrapName -> nam)) wild cons)) +#endif | nam == symbol = Nothing | otherwise = Just $ @@ -449,5 +648,7 @@ ty wild (filter ((/= symbol) . unqualIEWrapName . unLoc) cons) +#if !MIN_VERSION_ghc(9,2,0) (filter ((/= symbol) . T.pack . Util.unpackFS . flLabel . unLoc) flds) +#endif killLie v = Just v diff --git a/src/Development/IDE/Plugin/Completions.hs b/src/Development/IDE/Plugin/Completions.hs --- a/src/Development/IDE/Plugin/Completions.hs +++ b/src/Development/IDE/Plugin/Completions.hs @@ -1,14 +1,13 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} module Development.IDE.Plugin.Completions ( descriptor - , LocalCompletions(..) - , NonLocalCompletions(..) ) where import Control.Concurrent.Async (concurrently) -import Control.Concurrent.Extra +import Control.Concurrent.STM.Stats (readTVarIO) import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Trans.Maybe @@ -24,12 +23,9 @@ import Development.IDE.Core.Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.Error (rangeToSrcSpan) -import Development.IDE.GHC.ExactPrint (Annotated (annsA), - GetAnnotatedParsedSource (GetAnnotatedParsedSource), - astA) +import Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource (GetAnnotatedParsedSource)) import Development.IDE.GHC.Util (prettyPrint) import Development.IDE.Graph -import Development.IDE.Graph.Classes import Development.IDE.Plugin.CodeAction (newImport, newImportToEdit) import Development.IDE.Plugin.CodeAction.ExactPrint @@ -41,7 +37,6 @@ import qualified Development.IDE.Types.KnownTargets as KT import Development.IDE.Types.Location import GHC.Exts (fromList, toList) -import GHC.Generics import Ide.Plugin.Config (Config) import Ide.Types import qualified Language.LSP.Server as LSP @@ -89,7 +84,7 @@ _ -> return ([], Nothing) -- Drop any explicit imports in ImportDecl if not hidden -dropListFromImportDecl :: GenLocated SrcSpan (ImportDecl GhcPs) -> GenLocated SrcSpan (ImportDecl GhcPs) +dropListFromImportDecl :: LImportDecl GhcPs -> LImportDecl GhcPs dropListFromImportDecl iDecl = let f d@ImportDecl {ideclHiding} = case ideclHiding of Just (False, _) -> d {ideclHiding=Nothing} @@ -98,20 +93,6 @@ f x = x in f <$> iDecl --- | Produce completions info for a file -type instance RuleResult LocalCompletions = CachedCompletions -type instance RuleResult NonLocalCompletions = CachedCompletions - -data LocalCompletions = LocalCompletions - deriving (Eq, Show, Typeable, Generic) -instance Hashable LocalCompletions -instance NFData LocalCompletions - -data NonLocalCompletions = NonLocalCompletions - deriving (Eq, Show, Typeable, Generic) -instance Hashable NonLocalCompletions -instance NFData NonLocalCompletions - -- | Generate code actions. getCompletionsLSP :: IdeState @@ -138,7 +119,7 @@ -- set up the exports map including both package and project-level identifiers packageExportsMapIO <- fmap(envPackageExports . fst) <$> useWithStaleFast GhcSession npath packageExportsMap <- mapM liftIO packageExportsMapIO - projectExportsMap <- liftIO $ readVar (exportsMap $ shakeExtras ide) + projectExportsMap <- liftIO $ readTVarIO (exportsMap $ shakeExtras ide) let exportsMap = fromMaybe mempty packageExportsMap <> projectExportsMap let moduleExports = getModuleExportsMap exportsMap @@ -244,24 +225,31 @@ case existingImport of Just imp -> do fmap (nfp,) $ liftEither $ - rewriteToWEdit df doc (annsA ps) $ - extendImport (T.unpack <$> thingParent) (T.unpack newThing) imp + rewriteToWEdit df doc +#if !MIN_VERSION_ghc(9,2,0) + (annsA ps) +#endif + $ + extendImport (T.unpack <$> thingParent) (T.unpack newThing) (makeDeltaAst imp) Nothing -> do let n = newImport importName sym importQual False sym = if isNothing importQual then Just it else Nothing it = case thingParent of Nothing -> newThing Just p -> p <> "(" <> newThing <> ")" - t <- liftMaybe $ snd <$> newImportToEdit n (astA ps) (fromMaybe "" contents) + t <- liftMaybe $ snd <$> newImportToEdit + n + (astA ps) + (fromMaybe "" contents) return (nfp, WorkspaceEdit {_changes=Just (fromList [(doc,List [t])]), _documentChanges=Nothing, _changeAnnotations=Nothing}) | otherwise = mzero -isWantedModule :: ModuleName -> Maybe ModuleName -> GenLocated l (ImportDecl pass) -> Bool +isWantedModule :: ModuleName -> Maybe ModuleName -> GenLocated l (ImportDecl GhcPs) -> Bool isWantedModule wantedModule Nothing (L _ it@ImportDecl{ideclName, ideclHiding = Just (False, _)}) = not (isQualifiedImport it) && unLoc ideclName == wantedModule isWantedModule wantedModule (Just qual) (L _ ImportDecl{ideclAs, ideclName, ideclHiding = Just (False, _)}) = - unLoc ideclName == wantedModule && (wantedModule == qual || (unLoc <$> ideclAs) == Just qual) + unLoc ideclName == wantedModule && (wantedModule == qual || (unLoc . reLoc <$> ideclAs) == Just qual) isWantedModule _ _ _ = False liftMaybe :: Monad m => Maybe a -> MaybeT m a diff --git a/src/Development/IDE/Plugin/Completions/Logic.hs b/src/Development/IDE/Plugin/Completions/Logic.hs --- a/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/src/Development/IDE/Plugin/Completions/Logic.hs @@ -20,7 +20,6 @@ import qualified Data.Map as Map import Data.Maybe (fromMaybe, isJust, - listToMaybe, mapMaybe) import qualified Data.Text as T import qualified Text.Fuzzy.Parallel as Fuzzy @@ -32,11 +31,13 @@ import Data.Functor import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HashSet +import Data.Monoid (First(..)) import Data.Ord (Down (Down)) import qualified Data.Set as Set import Development.IDE.Core.Compile import Development.IDE.Core.PositionMapping -import Development.IDE.GHC.Compat as GHC hiding (ppr) +import Development.IDE.GHC.Compat hiding (ppr) +import qualified Development.IDE.GHC.Compat as GHC import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Error import Development.IDE.GHC.Util @@ -47,6 +48,15 @@ import Development.IDE.Types.Exports import Development.IDE.Types.HscEnvEq import Development.IDE.Types.Options + +#if MIN_VERSION_ghc(9,2,0) +import GHC.Plugins (Depth (AllTheWay), + defaultSDocContext, + mkUserStyle, + neverQualify, + renderWithContext, + sdocStyle) +#endif import Ide.PluginUtils (mkLspCommand) import Ide.Types (CommandId (..), PluginId) @@ -80,11 +90,11 @@ -- i.e. where are the value decls and the type decls getCContext :: Position -> ParsedModule -> Maybe Context getCContext pos pm - | Just (L r modName) <- moduleHeader + | Just (L (locA -> r) modName) <- moduleHeader , pos `isInsideSrcSpan` r = Just (ModuleContext (moduleNameString modName)) - | Just (L r _) <- exportList + | Just (L (locA -> r) _) <- exportList , pos `isInsideSrcSpan` r = Just ExportContext @@ -103,23 +113,23 @@ imports = hsmodImports $ unLoc $ pm_parsed_source pm go :: LHsDecl GhcPs -> Maybe Context - go (L r SigD {}) + go (L (locA -> r) SigD {}) | pos `isInsideSrcSpan` r = Just TypeContext | otherwise = Nothing - go (L r GHC.ValD {}) + go (L (locA -> r) GHC.ValD {}) | pos `isInsideSrcSpan` r = Just ValueContext | otherwise = Nothing go _ = Nothing goInline :: GHC.LHsType GhcPs -> Maybe Context - goInline (GHC.L r _) + goInline (GHC.L (locA -> r) _) | pos `isInsideSrcSpan` r = Just TypeContext goInline _ = Nothing importGo :: GHC.LImportDecl GhcPs -> Maybe Context - importGo (L r impDecl) + importGo (L (locA -> r) impDecl) | pos `isInsideSrcSpan` r - = importInline importModuleName (ideclHiding impDecl) + = importInline importModuleName (fmap (fmap reLoc) $ ideclHiding impDecl) <|> Just (ImportContext importModuleName) | otherwise = Nothing @@ -255,9 +265,9 @@ (TyVarTy _) -> noParensSnippet (LitTy _) -> noParensSnippet (TyConApp _ []) -> noParensSnippet - _ -> snippetText i ("(" <> showGhc t <> ")") + _ -> snippetText i ("(" <> showForSnippet t <> ")") where - noParensSnippet = snippetText i (showGhc t) + noParensSnippet = snippetText i (showForSnippet t) snippetText i t = "${" <> T.pack (show i) <> ":" <> t <> "}" getArgs :: Type -> [Type] getArgs t @@ -278,6 +288,16 @@ #endif | otherwise = [] + +showForSnippet :: Outputable a => a -> T.Text +#if MIN_VERSION_ghc(9,2,0) +showForSnippet x = T.pack $ renderWithContext ctxt $ GHC.ppr x -- FIXme + where + ctxt = defaultSDocContext{sdocStyle = mkUserStyle neverQualify AllTheWay} +#else +showForSnippet x = showGhc x +#endif + mkModCompl :: T.Text -> CompletionItem mkModCompl label = CompletionItem label (Just CiModule) Nothing Nothing @@ -332,12 +352,12 @@ curModName = moduleName curMod curModNameText = ppr curModName - importMap = Map.fromList [ (l, imp) | imp@(L (RealSrcSpan l _) _) <- limports ] + importMap = Map.fromList [ (l, imp) | imp@(L (locA -> (RealSrcSpan l _)) _) <- limports ] - iDeclToModName :: ImportDecl name -> ModuleName + iDeclToModName :: ImportDecl GhcPs -> ModuleName iDeclToModName = unLoc . ideclName - asNamespace :: ImportDecl name -> ModuleName + asNamespace :: ImportDecl GhcPs -> ModuleName asNamespace imp = maybe (iDeclToModName imp) GHC.unLoc (ideclAs imp) -- Full canonical names of imported modules importDeclerations = map unLoc limports @@ -383,7 +403,9 @@ let (mbParent, originName) = case par of NoParent -> (Nothing, nameOccName n) ParentIs n' -> (Just . T.pack $ printName n', nameOccName n) +#if !MIN_VERSION_ghc(9,2,0) FldParent n' lbl -> (Just . T.pack $ printName n', maybe (nameOccName n) mkVarOccFS lbl) +#endif tys <- catchSrcErrors (hsc_dflags packageState) "completion" $ do name' <- lookupName packageState m n return ( name' >>= safeTyThingType @@ -432,7 +454,7 @@ compls = concat [ case decl of SigD _ (TypeSig _ ids typ) -> - [mkComp id CiFunction (Just $ ppr typ) | id <- ids] + [mkComp id CiFunction (Just $ showForSnippet typ) | id <- ids] ValD _ FunBind{fun_id} -> [ mkComp fun_id CiFunction Nothing | not (hasTypeSig fun_id) @@ -441,13 +463,13 @@ [mkComp id CiVariable Nothing | VarPat _ id <- listify (\(_ :: Pat GhcPs) -> True) pat_lhs] TyClD _ ClassDecl{tcdLName, tcdSigs} -> - mkComp tcdLName CiInterface (Just $ ppr tcdLName) : - [ mkComp id CiFunction (Just $ ppr typ) + mkComp tcdLName CiInterface (Just $ showForSnippet tcdLName) : + [ mkComp id CiFunction (Just $ showForSnippet typ) | L _ (ClassOpSig _ _ ids typ) <- tcdSigs , id <- ids] TyClD _ x -> - let generalCompls = [mkComp id cl (Just $ ppr $ tcdLName x) - | id <- listify (\(_ :: Located(IdP GhcPs)) -> True) x + let generalCompls = [mkComp id cl (Just $ showForSnippet $ tyClDeclLName x) + | id <- listify (\(_ :: LIdP GhcPs) -> True) x , let cl = occNameToComKind Nothing (rdrNameOcc $ unLoc id)] -- here we only have to look at the outermost type recordCompls = findRecordCompl uri pm (Local pos) x @@ -455,11 +477,11 @@ -- the constructors and snippets will be duplicated here giving the user 2 choices. generalCompls ++ recordCompls ForD _ ForeignImport{fd_name,fd_sig_ty} -> - [mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)] + [mkComp fd_name CiVariable (Just $ showForSnippet fd_sig_ty)] ForD _ ForeignExport{fd_name,fd_sig_ty} -> - [mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)] + [mkComp fd_name CiVariable (Just $ showForSnippet fd_sig_ty)] _ -> [] - | L pos decl <- hsmodDecls, + | L (locA -> pos) decl <- hsmodDecls, let mkComp = mkLocalComp pos ] @@ -470,8 +492,8 @@ -- to tell local completions and global completions apart -- instead of using the empty string here, we should probably introduce a new field... ensureTypeText = Just $ fromMaybe "" ty - pn = ppr n - doc = SpanDocText (getDocumentation [pm] n) (SpanDocUris Nothing Nothing) + pn = showForSnippet n + doc = SpanDocText (getDocumentation [pm] $ reLoc n) (SpanDocUris Nothing Nothing) findRecordCompl :: Uri -> ParsedModule -> Provenance -> TyClDecl GhcPs -> [CompItem] findRecordCompl uri pmod mn DataDecl {tcdLName, tcdDataDefn} = result @@ -480,24 +502,30 @@ (showGhc . unLoc $ con_name) field_labels mn doc Nothing | ConDeclH98{..} <- unLoc <$> dd_cons tcdDataDefn , Just con_details <- [getFlds con_args] - , let field_names = mapMaybe extract con_details - , let field_labels = showGhc . unLoc <$> field_names + , let field_names = concatMap extract con_details + , let field_labels = showGhc <$> field_names , (not . List.null) field_labels ] - doc = SpanDocText (getDocumentation [pmod] tcdLName) (SpanDocUris Nothing Nothing) + doc = SpanDocText (getDocumentation [pmod] $ reLoc tcdLName) (SpanDocUris Nothing Nothing) - getFlds :: HsConDetails arg (Located [LConDeclField GhcPs]) -> Maybe [ConDeclField GhcPs] getFlds conArg = case conArg of RecCon rec -> Just $ unLoc <$> unLoc rec - PrefixCon _ -> Just [] + PrefixCon{} -> Just [] _ -> Nothing extract ConDeclField{..} - -- TODO: Why is cd_fld_names a list? - | Just fld_name <- rdrNameFieldOcc . unLoc <$> listToMaybe cd_fld_names = Just fld_name - | otherwise = Nothing + -- NOTE: 'cd_fld_names' is grouped so that the fields + -- sharing the same type declaration to fit in the same group; e.g. + -- + -- @ + -- data Foo = Foo {arg1, arg2 :: Int, arg3 :: Int, arg4 :: Bool} + -- @ + -- + -- is encoded as @[[arg1, arg2], [arg3], [arg4]]@ + -- Hence, we must concat nested arguments into one to get all the fields. + = map (rdrNameFieldOcc . unLoc) cd_fld_names -- XConDeclField - extract _ = Nothing + extract _ = [] findRecordCompl _ _ _ _ = [] ppr :: Outputable a => a -> T.Text @@ -596,8 +624,8 @@ where occ = nameOccName name ctyp = occNameToComKind Nothing occ - pn = ppr name - ty = ppr <$> typ + pn = showForSnippet name + ty = showForSnippet <$> typ thisModName = Local $ nameSrcSpan name compls = if T.null prefixModule @@ -681,14 +709,17 @@ importedFrom (provenance -> ImportedFrom m) = m importedFrom (provenance -> DefinedIn m) = m importedFrom (provenance -> Local _) = "local" +#if __GLASGOW_HASKELL__ < 810 + importedFrom _ = "" +#endif -- --------------------------------------------------------------------- -- helper functions for infix backticks -- --------------------------------------------------------------------- hasTrailingBacktick :: T.Text -> Position -> Bool -hasTrailingBacktick line Position { _character } - | T.length line > _character = (line `T.index` _character) == '`' +hasTrailingBacktick line Position { _character=(fromIntegral -> c) } + | T.length line > c = (line `T.index` c) == '`' | otherwise = False isUsedAsInfix :: T.Text -> T.Text -> T.Text -> Position -> Maybe Backtick @@ -701,8 +732,8 @@ hasClosingBacktick = hasTrailingBacktick line pos openingBacktick :: T.Text -> T.Text -> T.Text -> Position -> Bool -openingBacktick line prefixModule prefixText Position { _character } - | backtickIndex < 0 || backtickIndex > T.length line = False +openingBacktick line prefixModule prefixText Position { _character=(fromIntegral -> c) } + | backtickIndex < 0 || backtickIndex >= T.length line = False | otherwise = (line `T.index` backtickIndex) == '`' where backtickIndex :: Int @@ -714,7 +745,7 @@ else T.length prefixModule + 1 {- Because of "." -} in -- Points to the first letter of either the module or prefix text - _character - (prefixLength + moduleLength) - 1 + c - (prefixLength + moduleLength) - 1 -- --------------------------------------------------------------------- @@ -727,12 +758,8 @@ -} -- TODO: Turn this into an alex lexer that discards prefixes as if they were whitespace. stripPrefix :: T.Text -> T.Text -stripPrefix name = T.takeWhile (/=':') $ go prefixes - where - go [] = name - go (p:ps) - | T.isPrefixOf p name = T.drop (T.length p) name - | otherwise = go ps +stripPrefix name = T.takeWhile (/=':') $ fromMaybe name $ + getFirst $ foldMap (First . (`T.stripPrefix` name)) prefixes -- | Prefixes that can occur in a GHC OccName prefixes :: [T.Text] diff --git a/src/Development/IDE/Plugin/Completions/Types.hs b/src/Development/IDE/Plugin/Completions/Types.hs --- a/src/Development/IDE/Plugin/Completions/Types.hs +++ b/src/Development/IDE/Plugin/Completions/Types.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TypeFamilies #-} module Development.IDE.Plugin.Completions.Types ( module Development.IDE.Plugin.Completions.Types ) where @@ -11,8 +12,11 @@ import qualified Data.Text as T import Data.Aeson (FromJSON, ToJSON) +import Data.Hashable (Hashable) import Data.Text (Text) +import Data.Typeable (Typeable) import Development.IDE.GHC.Compat +import Development.IDE.Graph (RuleResult) import Development.IDE.Spans.Common import GHC.Generics (Generic) import Ide.Plugin.Config (Config) @@ -22,6 +26,20 @@ import Ide.Types (PluginId) import Language.LSP.Server (MonadLsp) import Language.LSP.Types (CompletionItemKind (..), Uri) + +-- | Produce completions info for a file +type instance RuleResult LocalCompletions = CachedCompletions +type instance RuleResult NonLocalCompletions = CachedCompletions + +data LocalCompletions = LocalCompletions + deriving (Eq, Show, Typeable, Generic) +instance Hashable LocalCompletions +instance NFData LocalCompletions + +data NonLocalCompletions = NonLocalCompletions + deriving (Eq, Show, Typeable, Generic) +instance Hashable NonLocalCompletions +instance NFData NonLocalCompletions -- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs diff --git a/src/Development/IDE/Plugin/Test.hs b/src/Development/IDE/Plugin/Test.hs --- a/src/Development/IDE/Plugin/Test.hs +++ b/src/Development/IDE/Plugin/Test.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE PolyKinds #-} -- | A plugin that adds custom messages for use in tests module Development.IDE.Plugin.Test @@ -12,7 +13,6 @@ ) where import Control.Concurrent (threadDelay) -import Control.Concurrent.Extra (readVar) import Control.Monad import Control.Monad.IO.Class import Control.Monad.STM @@ -46,6 +46,8 @@ import Ide.Types import qualified Language.LSP.Server as LSP import Language.LSP.Types +import qualified "list-t" ListT +import qualified StmContainers.Map as STM import System.Time.Extra type Age = Int @@ -124,7 +126,7 @@ res <- liftIO $ runAction "garbage collect dirty" s $ garbageCollectDirtyKeysOlderThan age parents return $ Right $ toJSON $ map show res testRequestHandler s GetStoredKeys = do - keys <- liftIO $ HM.keys <$> readVar (state $ shakeExtras s) + keys <- liftIO $ atomically $ map fst <$> ListT.toList (STM.listT $ state $ shakeExtras s) return $ Right $ toJSON $ map show keys testRequestHandler s GetFilesOfInterest = do ff <- liftIO $ getFilesOfInterest s diff --git a/src/Development/IDE/Plugin/TypeLenses.hs b/src/Development/IDE/Plugin/TypeLenses.hs --- a/src/Development/IDE/Plugin/TypeLenses.hs +++ b/src/Development/IDE/Plugin/TypeLenses.hs @@ -12,6 +12,7 @@ GlobalBindingTypeSigsResult (..), ) where +import Control.Concurrent.STM.Stats (atomically) import Control.DeepSeq (rwhnf) import Control.Monad (mzero) import Control.Monad.Extra (whenMaybe) @@ -96,12 +97,13 @@ mode <- usePropertyLsp #mode pId properties fmap (Right . List) $ case uriToFilePath' uri of Just (toNormalizedFilePath' -> filePath) -> liftIO $ do + env <- fmap hscEnv <$> runAction "codeLens.GhcSession" ideState (use GhcSession filePath) tmr <- runAction "codeLens.TypeCheck" ideState (use TypeCheck filePath) bindings <- runAction "codeLens.GetBindings" ideState (use GetBindings filePath) gblSigs <- runAction "codeLens.GetGlobalBindingTypeSigs" ideState (use GetGlobalBindingTypeSigs filePath) - diag <- getDiagnostics ideState - hDiag <- getHiddenDiagnostics ideState + diag <- atomically $ getDiagnostics ideState + hDiag <- atomically $ getHiddenDiagnostics ideState let toWorkSpaceEdit tedit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing generateLensForGlobal sig@GlobalBindingTypeSig{..} = do @@ -122,9 +124,9 @@ case mode of Always -> pure (catMaybes $ generateLensForGlobal <$> gblSigs') - <> generateLensFromDiags (suggestLocalSignature False tmr bindings) -- we still need diagnostics for local bindings + <> generateLensFromDiags (suggestLocalSignature False env tmr bindings) -- we still need diagnostics for local bindings Exported -> pure $ catMaybes $ generateLensForGlobal <$> filter gbExported gblSigs' - Diagnostics -> generateLensFromDiags $ suggestSignature False gblSigs tmr bindings + Diagnostics -> generateLensFromDiags $ suggestSignature False env gblSigs tmr bindings Nothing -> pure [] generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> CodeLens @@ -139,9 +141,9 @@ -------------------------------------------------------------------------------- -suggestSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])] -suggestSignature isQuickFix mGblSigs mTmr mBindings diag = - suggestGlobalSignature isQuickFix mGblSigs diag <> suggestLocalSignature isQuickFix mTmr mBindings diag +suggestSignature :: Bool -> Maybe HscEnv -> Maybe GlobalBindingTypeSigsResult -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])] +suggestSignature isQuickFix env mGblSigs mTmr mBindings diag = + suggestGlobalSignature isQuickFix mGblSigs diag <> suggestLocalSignature isQuickFix env mTmr mBindings diag suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> [(T.Text, [TextEdit])] suggestGlobalSignature isQuickFix mGblSigs Diagnostic{_message, _range} @@ -155,25 +157,26 @@ [(title, [action])] | otherwise = [] -suggestLocalSignature :: Bool -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])] -suggestLocalSignature isQuickFix mTmr mBindings Diagnostic{_message, _range = _range@Range{..}} +suggestLocalSignature :: Bool -> Maybe HscEnv -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])] +suggestLocalSignature isQuickFix mEnv mTmr mBindings Diagnostic{_message, _range = _range@Range{..}} | Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, [identifier]) <- (T.unwords . T.words $ _message) =~~ ("Polymorphic local binding with no type signature: (.*) ::" :: T.Text) , Just bindings <- mBindings + , Just env <- mEnv , localScope <- getFuzzyScope bindings _start _end , -- we can't use srcspan to lookup scoped bindings, because the error message reported by GHC includes the entire binding, instead of simply the name Just (name, ty) <- find (\(x, _) -> printName x == T.unpack identifier) localScope >>= \(name, mTy) -> (name,) <$> mTy , Just TcModuleResult{tmrTypechecked = TcGblEnv{tcg_rdr_env, tcg_sigs}} <- mTmr , -- not a top-level thing, to avoid duplication not $ name `elemNameSet` tcg_sigs - , tyMsg <- printSDocQualifiedUnsafe (mkPrintUnqualifiedDefault tcg_rdr_env) $ pprSigmaType ty + , tyMsg <- printSDocQualifiedUnsafe (mkPrintUnqualifiedDefault env tcg_rdr_env) $ pprSigmaType ty , signature <- T.pack $ printName name <> " :: " <> tyMsg , startCharacter <- _character _start , startOfLine <- Position (_line _start) startCharacter , beforeLine <- Range startOfLine startOfLine , title <- if isQuickFix then "add signature: " <> signature else signature - , action <- TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " " = + , action <- TextEdit beforeLine $ signature <> "\n" <> T.replicate (fromIntegral startCharacter) " " = [(title, [action])] | otherwise = [] @@ -212,7 +215,7 @@ -------------------------------------------------------------------------------- showDocRdrEnv :: HscEnv -> GlobalRdrEnv -> SDoc -> String -showDocRdrEnv env rdrEnv = showSDocForUser (hsc_dflags env) (mkPrintUnqualified (hsc_dflags env) rdrEnv) +showDocRdrEnv env rdrEnv = showSDocForUser' env (mkPrintUnqualifiedDefault env rdrEnv) data GetGlobalBindingTypeSigs = GetGlobalBindingTypeSigs deriving (Generic, Show, Eq, Ord, Hashable, NFData) diff --git a/src/Development/IDE/Spans/AtPoint.hs b/src/Development/IDE/Spans/AtPoint.hs --- a/src/Development/IDE/Spans/AtPoint.hs +++ b/src/Development/IDE/Spans/AtPoint.hs @@ -1,8 +1,9 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} -- | Gives information about symbols at a given point in DAML files. -- These are all pure functions that should execute quickly. @@ -51,6 +52,7 @@ import Data.List.Extra (dropEnd1, nubOrd) import Data.Version (showVersion) +import Development.IDE.Types.Shake (WithHieDb) import HieDb hiding (pointCommand) import System.Directory (doesFileExist) @@ -106,12 +108,12 @@ referencesAtPoint :: MonadIO m - => HieDb + => WithHieDb -> NormalizedFilePath -- ^ The file the cursor is in -> Position -- ^ position in the file -> FOIReferences -- ^ references data for FOIs -> m [Location] -referencesAtPoint hiedb nfp pos refs = do +referencesAtPoint withHieDb nfp pos refs = do -- The database doesn't have up2date references data for the FOIs so we must collect those -- from the Shake graph. let (names, foiRefs, exclude) = foiReferencesAtPoint nfp pos refs @@ -121,12 +123,12 @@ Just mod -> do -- Look for references (strictly in project files, not dependencies), -- excluding the files in the FOIs (since those are in foiRefs) - rows <- liftIO $ findReferences hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod) exclude + rows <- liftIO $ withHieDb (\hieDb -> findReferences hieDb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod) exclude) pure $ mapMaybe rowToLoc rows typeRefs <- forM names $ \name -> case nameModule_maybe name of Just mod | isTcClsNameSpace (occNameSpace $ nameOccName name) -> do - refs <- liftIO $ findTypeRefs hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod) exclude + refs <- liftIO $ withHieDb (\hieDb -> findTypeRefs hieDb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod) exclude) pure $ mapMaybe typeRowToLoc refs _ -> pure [] pure $ nubOrd $ foiRefs ++ concat nonFOIRefs ++ concat typeRefs @@ -135,8 +137,8 @@ rowToLoc (row:.info) = flip Location range <$> mfile where range = Range start end - start = Position (refSLine row - 1) (refSCol row -1) - end = Position (refELine row - 1) (refECol row -1) + start = Position (fromIntegral $ refSLine row - 1) (fromIntegral $ refSCol row -1) + end = Position (fromIntegral $ refELine row - 1) (fromIntegral $ refECol row -1) mfile = case modInfoSrcFile info of Just f -> Just $ toUri f Nothing -> Nothing @@ -147,8 +149,8 @@ pure $ Location (toUri file) range where range = Range start end - start = Position (typeRefSLine row - 1) (typeRefSCol row -1) - end = Position (typeRefELine row - 1) (typeRefECol row -1) + start = Position (fromIntegral $ typeRefSLine row - 1) (fromIntegral $ typeRefSCol row -1) + end = Position (fromIntegral $ typeRefELine row - 1) (fromIntegral $ typeRefECol row -1) documentHighlight :: Monad m @@ -158,7 +160,13 @@ -> MaybeT m [DocumentHighlight] documentHighlight hf rf pos = pure highlights where - ns = concat $ pointCommand hf pos (rights . M.keys . getNodeIds) +#if MIN_VERSION_ghc(9,0,1) + -- We don't want to show document highlights for evidence variables, which are supposed to be invisible + notEvidence = not . any isEvidenceContext . identInfo +#else + notEvidence = const True +#endif + ns = concat $ pointCommand hf pos (rights . M.keys . M.filter notEvidence . getNodeIds) highlights = do n <- ns ref <- fromMaybe [] (M.lookup (Right n) rf) @@ -172,27 +180,27 @@ gotoTypeDefinition :: MonadIO m - => HieDb + => WithHieDb -> LookupModule m -> IdeOptions -> HieAstResult -> Position -> MaybeT m [Location] -gotoTypeDefinition hiedb lookupModule ideOpts srcSpans pos - = lift $ typeLocationsAtPoint hiedb lookupModule ideOpts pos srcSpans +gotoTypeDefinition withHieDb lookupModule ideOpts srcSpans pos + = lift $ typeLocationsAtPoint withHieDb lookupModule ideOpts pos srcSpans -- | Locate the definition of the name at a given position. gotoDefinition :: MonadIO m - => HieDb + => WithHieDb -> LookupModule m -> IdeOptions -> M.Map ModuleName NormalizedFilePath -> HieASTs a -> Position -> MaybeT m [Location] -gotoDefinition hiedb getHieFile ideOpts imports srcSpans pos - = lift $ locationsAtPoint hiedb getHieFile ideOpts imports pos srcSpans +gotoDefinition withHieDb getHieFile ideOpts imports srcSpans pos + = lift $ locationsAtPoint withHieDb getHieFile ideOpts imports pos srcSpans -- | Synopsis for the name at a given position. atPoint @@ -252,13 +260,13 @@ typeLocationsAtPoint :: forall m . MonadIO m - => HieDb + => WithHieDb -> LookupModule m -> IdeOptions -> Position -> HieAstResult -> m [Location] -typeLocationsAtPoint hiedb lookupModule _ideOptions pos (HAR _ ast _ _ hieKind) = +typeLocationsAtPoint withHieDb lookupModule _ideOptions pos (HAR _ ast _ _ hieKind) = case hieKind of HieFromDisk hf -> let arr = hie_types hf @@ -283,12 +291,12 @@ HQualTy a b -> getTypes [a,b] HCastTy a -> getTypes [a] _ -> [] - in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation hiedb lookupModule) (getTypes ts) + in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts) HieFresh -> let ts = concat $ pointCommand ast pos getts getts x = nodeType ni ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni) where ni = nodeInfo x - in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation hiedb lookupModule) (getTypes ts) + in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts) namesInType :: Type -> [Name] namesInType (TyVarTy n) = [varName n] @@ -306,23 +314,23 @@ locationsAtPoint :: forall m a . MonadIO m - => HieDb + => WithHieDb -> LookupModule m -> IdeOptions -> M.Map ModuleName NormalizedFilePath -> Position -> HieASTs a -> m [Location] -locationsAtPoint hiedb lookupModule _ideOptions imports pos ast = +locationsAtPoint withHieDb lookupModule _ideOptions imports pos ast = let ns = concat $ pointCommand ast pos (M.keys . getNodeIds) zeroPos = Position 0 0 zeroRange = Range zeroPos zeroPos modToLocation m = fmap (\fs -> pure $ Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) $ M.lookup m imports - in fmap (nubOrd . concat) $ mapMaybeM (either (pure . modToLocation) $ nameToLocation hiedb lookupModule) ns + in fmap (nubOrd . concat) $ mapMaybeM (either (pure . modToLocation) $ nameToLocation withHieDb lookupModule) ns -- | Given a 'Name' attempt to find the location where it is defined. -nameToLocation :: MonadIO m => HieDb -> LookupModule m -> Name -> m (Maybe [Location]) -nameToLocation hiedb lookupModule name = runMaybeT $ +nameToLocation :: MonadIO m => WithHieDb -> LookupModule m -> Name -> m (Maybe [Location]) +nameToLocation withHieDb lookupModule name = runMaybeT $ case nameSrcSpan name of sp@(RealSrcSpan rsp _) -- Lookup in the db if we got a location in a boot file @@ -344,14 +352,14 @@ -- In this case the interface files contain garbage source spans -- so we instead read the .hie files to get useful source spans. mod <- MaybeT $ return $ nameModule_maybe name - erow <- liftIO $ findDef hiedb (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod) + erow <- liftIO $ withHieDb (\hieDb -> findDef hieDb (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod)) case erow of [] -> do -- If the lookup failed, try again without specifying a unit-id. -- This is a hack to make find definition work better with ghcide's nascent multi-component support, -- where names from a component that has been indexed in a previous session but not loaded in this -- session may end up with different unit ids - erow <- liftIO $ findDef hiedb (nameOccName name) (Just $ moduleName mod) Nothing + erow <- liftIO $ withHieDb (\hieDb -> findDef hieDb (nameOccName name) (Just $ moduleName mod) Nothing) case erow of [] -> MaybeT $ pure Nothing xs -> lift $ mapMaybeM (runMaybeT . defRowToLocation lookupModule) xs @@ -359,8 +367,8 @@ defRowToLocation :: Monad m => LookupModule m -> Res DefRow -> MaybeT m Location defRowToLocation lookupModule (row:.info) = do - let start = Position (defSLine row - 1) (defSCol row - 1) - end = Position (defELine row - 1) (defECol row - 1) + let start = Position (fromIntegral $ defSLine row - 1) (fromIntegral $ defSCol row - 1) + end = Position (fromIntegral $ defELine row - 1) (fromIntegral $ defECol row - 1) range = Range start end file <- case modInfoSrcFile info of Just src -> pure $ toUri src @@ -382,8 +390,8 @@ loc = Location file range file = fromNormalizedUri . filePathToUri' . toNormalizedFilePath' $ srcFile range = Range start end - start = Position (defSLine - 1) (defSCol - 1) - end = Position (defELine - 1) (defECol - 1) + start = Position (fromIntegral $ defSLine - 1) (fromIntegral $ defSCol - 1) + end = Position (fromIntegral $ defELine - 1) (fromIntegral $ defECol - 1) defRowToSymbolInfo _ = Nothing pointCommand :: HieASTs t -> Position -> (HieAST t -> a) -> [a] @@ -403,7 +411,7 @@ Nothing -> Nothing Just ast' -> Just $ k ast' where - sloc fs = mkRealSrcLoc fs (line+1) (cha+1) + sloc fs = mkRealSrcLoc fs (fromIntegral $ line+1) (fromIntegral $ cha+1) sp fs = mkRealSrcSpan (sloc fs) (sloc fs) line = _line pos cha = _character pos diff --git a/src/Development/IDE/Spans/Documentation.hs b/src/Development/IDE/Spans/Documentation.hs --- a/src/Development/IDE/Spans/Documentation.hs +++ b/src/Development/IDE/Spans/Documentation.hs @@ -1,213 +1,224 @@ -{-# LANGUAGE RankNTypes #-} --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE CPP #-} - -module Development.IDE.Spans.Documentation ( - getDocumentation - , getDocumentationTryGhc - , getDocumentationsTryGhc - , DocMap - , mkDocMap - ) where - -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Extra (findM) -import Data.Either -import Data.Foldable -import Data.List.Extra -import qualified Data.Map as M -import Data.Maybe -import qualified Data.Set as S -import qualified Data.Text as T -import Development.IDE.Core.Compile -import Development.IDE.Core.RuleTypes -import Development.IDE.GHC.Compat -import Development.IDE.GHC.Compat.Util -import Development.IDE.GHC.Error -import Development.IDE.Spans.Common -import System.Directory -import System.FilePath - -import Language.LSP.Types (filePathToUri, getUri) - -mkDocMap - :: HscEnv - -> RefMap a - -> TcGblEnv - -> IO DocAndKindMap -mkDocMap env rm this_mod = - do let (_ , DeclDocMap this_docs, _) = extractDocs this_mod - d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names - k <- foldrM getType (tcg_type_env this_mod) names - pure $ DKMap d k - where - getDocs n map - | maybe True (mod ==) $ nameModule_maybe n = pure map -- we already have the docs in this_docs, or they do not exist - | otherwise = do - doc <- getDocumentationTryGhc env mod n - pure $ extendNameEnv map n doc - getType n map - | isTcOcc $ occName n = do - kind <- lookupKind env mod n - pure $ maybe map (extendNameEnv map n) kind - | otherwise = pure map - names = rights $ S.toList idents - idents = M.keysSet rm - mod = tcg_mod this_mod - -lookupKind :: HscEnv -> Module -> Name -> IO (Maybe TyThing) -lookupKind env mod = - fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod - -getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc -getDocumentationTryGhc env mod n = head <$> getDocumentationsTryGhc env mod [n] - -getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO [SpanDoc] -getDocumentationsTryGhc env mod names = do - res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env mod names - case res of - Left _ -> return [] - Right res -> zipWithM unwrap res names - where - unwrap (Right (Just docs, _)) n = SpanDocString docs <$> getUris n - unwrap _ n = mkSpanDocText n - - mkSpanDocText name = - SpanDocText [] <$> getUris name - - -- Get the uris to the documentation and source html pages if they exist - getUris name = do - (docFu, srcFu) <- - case nameModule_maybe name of - Just mod -> liftIO $ do - doc <- toFileUriText $ lookupDocHtmlForModule env mod - src <- toFileUriText $ lookupSrcHtmlForModule env mod - return (doc, src) - Nothing -> pure (Nothing, Nothing) - let docUri = (<> "#" <> selector <> showNameWithoutUniques name) <$> docFu - srcUri = (<> "#" <> showNameWithoutUniques name) <$> srcFu - selector - | isValName name = "v:" - | otherwise = "t:" - return $ SpanDocUris docUri srcUri - - toFileUriText = (fmap . fmap) (getUri . filePathToUri) - -getDocumentation - :: HasSrcSpan name - => [ParsedModule] -- ^ All of the possible modules it could be defined in. - -> name -- ^ The name you want documentation for. - -> [T.Text] --- This finds any documentation between the name you want --- documentation for and the one before it. This is only an --- approximately correct algorithm and there are easily constructed --- cases where it will be wrong (if so then usually slightly but there --- may be edge cases where it is very wrong). --- TODO : Build a version of GHC exactprint to extract this information --- more accurately. -getDocumentation sources targetName = fromMaybe [] $ do - -- Find the module the target is defined in. - targetNameSpan <- realSpan $ getLoc targetName - tc <- - find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName) - $ reverse sources -- TODO : Is reversing the list here really neccessary? - - -- Top level names bound by the module - let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc - , L _ (ValD _ hsbind) <- hsmodDecls - , Just n <- [name_of_bind hsbind] - ] - -- Sort the names' source spans. - let sortedSpans = sortedNameSpans bs - -- Now go ahead and extract the docs. - let docs = ann tc - nameInd <- elemIndex targetNameSpan sortedSpans - let prevNameSpan = - if nameInd >= 1 - then sortedSpans !! (nameInd - 1) - else zeroSpan $ srcSpanFile targetNameSpan - -- Annoyingly "-- |" documentation isn't annotated with a location, - -- so you have to pull it out from the elements. - pure - $ docHeaders - $ filter (\(L target _) -> isBetween target prevNameSpan targetNameSpan) - $ fold - docs - where - -- Get the name bound by a binding. We only concern ourselves with - -- @FunBind@ (which covers functions and variables). - name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName) - name_of_bind FunBind {fun_id} = Just fun_id - name_of_bind _ = Nothing - -- Get source spans from names, discard unhelpful spans, remove - -- duplicates and sort. - sortedNameSpans :: [Located RdrName] -> [RealSrcSpan] - sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls) - isBetween target before after = before <= target && target <= after -#if MIN_VERSION_ghc(9,0,0) - ann = apiAnnComments . pm_annotations -#else - ann = fmap filterReal . snd . pm_annotations - filterReal :: [Located a] -> [RealLocated a] - filterReal = mapMaybe (\(L l v) -> (`L`v) <$> realSpan l) -#endif - annotationFileName :: ParsedModule -> Maybe FastString - annotationFileName = fmap srcSpanFile . listToMaybe . map getRealSrcSpan . fold . ann - --- | Shows this part of the documentation -docHeaders :: [RealLocated AnnotationComment] - -> [T.Text] -docHeaders = mapMaybe (\(L _ x) -> wrk x) - where - wrk = \case - -- When `Opt_Haddock` is enabled. - AnnDocCommentNext s -> Just $ T.pack s - -- When `Opt_KeepRawTokenStream` enabled. - AnnLineComment s -> if "-- |" `isPrefixOf` s - then Just $ T.pack s - else Nothing - _ -> Nothing - --- These are taken from haskell-ide-engine's Haddock plugin - --- | Given a module finds the local @doc/html/Foo-Bar-Baz.html@ page. --- An example for a cabal installed module: --- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/Data-Vector-Primitive.html@ -lookupDocHtmlForModule :: HscEnv -> Module -> IO (Maybe FilePath) -lookupDocHtmlForModule = - lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir modDocName <.> "html") - --- | Given a module finds the hyperlinked source @doc/html/src/Foo.Bar.Baz.html@ page. --- An example for a cabal installed module: --- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/src/Data.Vector.Primitive.html@ -lookupSrcHtmlForModule :: HscEnv -> Module -> IO (Maybe FilePath) -lookupSrcHtmlForModule = - lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir "src" modDocName <.> "html") - -lookupHtmlForModule :: (FilePath -> FilePath -> FilePath) -> HscEnv -> Module -> IO (Maybe FilePath) -lookupHtmlForModule mkDocPath hscEnv m = do - -- try all directories - let mfs = fmap (concatMap go) (lookupHtmls hscEnv ui) - html <- findM doesFileExist (concat . maybeToList $ mfs) - -- canonicalize located html to remove /../ indirection which can break some clients - -- (vscode on Windows at least) - traverse canonicalizePath html - where - go pkgDocDir = map (mkDocPath pkgDocDir) mns - ui = moduleUnit m - -- try to locate html file from most to least specific name e.g. - -- first Language.LSP.Types.Uri.html and Language-Haskell-LSP-Types-Uri.html - -- then Language.LSP.Types.html and Language-Haskell-LSP-Types.html etc. - mns = do - chunks <- (reverse . drop1 . inits . splitOn ".") $ (moduleNameString . moduleName) m - -- The file might use "." or "-" as separator - map (`intercalate` chunks) [".", "-"] - -lookupHtmls :: HscEnv -> Unit -> Maybe [FilePath] -lookupHtmls df ui = - -- use haddockInterfaces instead of haddockHTMLs: GHC treats haddockHTMLs as URL not path - -- and therefore doesn't expand $topdir on Windows - map takeDirectory . unitHaddockInterfaces <$> lookupUnit df ui +{-# LANGUAGE RankNTypes #-} +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE CPP #-} + +module Development.IDE.Spans.Documentation ( + getDocumentation + , getDocumentationTryGhc + , getDocumentationsTryGhc + , DocMap + , mkDocMap + ) where + +import Control.Monad +import Control.Monad.Extra (findM) +import Control.Monad.IO.Class +import Data.Either +import Data.Foldable +import Data.List.Extra +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Set as S +import qualified Data.Text as T +import Development.IDE.Core.Compile +import Development.IDE.Core.RuleTypes +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.Util +import Development.IDE.GHC.Error +import Development.IDE.Spans.Common +import System.Directory +import System.FilePath + +import Language.LSP.Types (filePathToUri, getUri) + +mkDocMap + :: HscEnv + -> RefMap a + -> TcGblEnv + -> IO DocAndKindMap +mkDocMap env rm this_mod = + do +#if MIN_VERSION_ghc(9,2,0) + (_ , DeclDocMap this_docs, _) <- extractDocs this_mod +#else + let (_ , DeclDocMap this_docs, _) = extractDocs this_mod +#endif + d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names + k <- foldrM getType (tcg_type_env this_mod) names + pure $ DKMap d k + where + getDocs n map + | maybe True (mod ==) $ nameModule_maybe n = pure map -- we already have the docs in this_docs, or they do not exist + | otherwise = do + doc <- getDocumentationTryGhc env mod n + pure $ extendNameEnv map n doc + getType n map + | isTcOcc $ occName n = do + kind <- lookupKind env mod n + pure $ maybe map (extendNameEnv map n) kind + | otherwise = pure map + names = rights $ S.toList idents + idents = M.keysSet rm + mod = tcg_mod this_mod + +lookupKind :: HscEnv -> Module -> Name -> IO (Maybe TyThing) +lookupKind env mod = + fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod + +getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc +getDocumentationTryGhc env mod n = head <$> getDocumentationsTryGhc env mod [n] + +getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO [SpanDoc] +getDocumentationsTryGhc env mod names = do + res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env mod names + case res of + Left _ -> return [] + Right res -> zipWithM unwrap res names + where + unwrap (Right (Just docs, _)) n = SpanDocString docs <$> getUris n + unwrap _ n = mkSpanDocText n + + mkSpanDocText name = + SpanDocText [] <$> getUris name + + -- Get the uris to the documentation and source html pages if they exist + getUris name = do + (docFu, srcFu) <- + case nameModule_maybe name of + Just mod -> liftIO $ do + doc <- toFileUriText $ lookupDocHtmlForModule env mod + src <- toFileUriText $ lookupSrcHtmlForModule env mod + return (doc, src) + Nothing -> pure (Nothing, Nothing) + let docUri = (<> "#" <> selector <> showNameWithoutUniques name) <$> docFu + srcUri = (<> "#" <> showNameWithoutUniques name) <$> srcFu + selector + | isValName name = "v:" + | otherwise = "t:" + return $ SpanDocUris docUri srcUri + + toFileUriText = (fmap . fmap) (getUri . filePathToUri) + +getDocumentation + :: HasSrcSpan name + => [ParsedModule] -- ^ All of the possible modules it could be defined in. + -> name -- ^ The name you want documentation for. + -> [T.Text] +-- This finds any documentation between the name you want +-- documentation for and the one before it. This is only an +-- approximately correct algorithm and there are easily constructed +-- cases where it will be wrong (if so then usually slightly but there +-- may be edge cases where it is very wrong). +-- TODO : Build a version of GHC exactprint to extract this information +-- more accurately. +-- TODO : Implement this for GHC 9.2 with in-tree annotations +-- (alternatively, just remove it and rely soley on GHC's parsing) +getDocumentation sources targetName = fromMaybe [] $ do +#if MIN_VERSION_ghc(9,2,0) + Nothing +#else + -- Find the module the target is defined in. + targetNameSpan <- realSpan $ getLoc targetName + tc <- + find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName) + $ reverse sources -- TODO : Is reversing the list here really neccessary? + + -- Top level names bound by the module + let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc + , L _ (ValD _ hsbind) <- hsmodDecls + , Just n <- [name_of_bind hsbind] + ] + -- Sort the names' source spans. + let sortedSpans = sortedNameSpans bs + -- Now go ahead and extract the docs. + let docs = ann tc + nameInd <- elemIndex targetNameSpan sortedSpans + let prevNameSpan = + if nameInd >= 1 + then sortedSpans !! (nameInd - 1) + else zeroSpan $ srcSpanFile targetNameSpan + -- Annoyingly "-- |" documentation isn't annotated with a location, + -- so you have to pull it out from the elements. + pure + $ docHeaders + $ filter (\(L target _) -> isBetween target prevNameSpan targetNameSpan) + $ fold + docs + where + -- Get the name bound by a binding. We only concern ourselves with + -- @FunBind@ (which covers functions and variables). + name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName) + name_of_bind FunBind {fun_id} = Just fun_id + name_of_bind _ = Nothing + -- Get source spans from names, discard unhelpful spans, remove + -- duplicates and sort. + sortedNameSpans :: [Located RdrName] -> [RealSrcSpan] + sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls) + isBetween target before after = before <= target && target <= after +#if MIN_VERSION_ghc(9,0,0) + ann = apiAnnComments . pm_annotations +#else + ann = fmap filterReal . snd . pm_annotations + filterReal :: [Located a] -> [RealLocated a] + filterReal = mapMaybe (\(L l v) -> (`L`v) <$> realSpan l) +#endif + annotationFileName :: ParsedModule -> Maybe FastString + annotationFileName = fmap srcSpanFile . listToMaybe . map getRealSrcSpan . fold . ann + +-- | Shows this part of the documentation +docHeaders :: [RealLocated AnnotationComment] + -> [T.Text] +docHeaders = mapMaybe (\(L _ x) -> wrk x) + where + wrk = \case + -- When `Opt_Haddock` is enabled. + AnnDocCommentNext s -> Just $ T.pack s + -- When `Opt_KeepRawTokenStream` enabled. + AnnLineComment s -> if "-- |" `isPrefixOf` s + then Just $ T.pack s + else Nothing + _ -> Nothing +#endif + +-- These are taken from haskell-ide-engine's Haddock plugin + +-- | Given a module finds the local @doc/html/Foo-Bar-Baz.html@ page. +-- An example for a cabal installed module: +-- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/Data-Vector-Primitive.html@ +lookupDocHtmlForModule :: HscEnv -> Module -> IO (Maybe FilePath) +lookupDocHtmlForModule = + lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir modDocName <.> "html") + +-- | Given a module finds the hyperlinked source @doc/html/src/Foo.Bar.Baz.html@ page. +-- An example for a cabal installed module: +-- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/src/Data.Vector.Primitive.html@ +lookupSrcHtmlForModule :: HscEnv -> Module -> IO (Maybe FilePath) +lookupSrcHtmlForModule = + lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir "src" modDocName <.> "html") + +lookupHtmlForModule :: (FilePath -> FilePath -> FilePath) -> HscEnv -> Module -> IO (Maybe FilePath) +lookupHtmlForModule mkDocPath hscEnv m = do + -- try all directories + let mfs = fmap (concatMap go) (lookupHtmls hscEnv ui) + html <- findM doesFileExist (concat . maybeToList $ mfs) + -- canonicalize located html to remove /../ indirection which can break some clients + -- (vscode on Windows at least) + traverse canonicalizePath html + where + go pkgDocDir = map (mkDocPath pkgDocDir) mns + ui = moduleUnit m + -- try to locate html file from most to least specific name e.g. + -- first Language.LSP.Types.Uri.html and Language-Haskell-LSP-Types-Uri.html + -- then Language.LSP.Types.html and Language-Haskell-LSP-Types.html etc. + mns = do + chunks <- (reverse . drop1 . inits . splitOn ".") $ (moduleNameString . moduleName) m + -- The file might use "." or "-" as separator + map (`intercalate` chunks) [".", "-"] + +lookupHtmls :: HscEnv -> Unit -> Maybe [FilePath] +lookupHtmls df ui = + -- use haddockInterfaces instead of haddockHTMLs: GHC treats haddockHTMLs as URL not path + -- and therefore doesn't expand $topdir on Windows + map takeDirectory . unitHaddockInterfaces <$> lookupUnit df ui diff --git a/src/Development/IDE/Spans/LocalBindings.hs b/src/Development/IDE/Spans/LocalBindings.hs --- a/src/Development/IDE/Spans/LocalBindings.hs +++ b/src/Development/IDE/Spans/LocalBindings.hs @@ -1,140 +1,140 @@ -{-# LANGUAGE DerivingStrategies #-} - -module Development.IDE.Spans.LocalBindings - ( Bindings - , getLocalScope - , getFuzzyScope - , getDefiningBindings - , getFuzzyDefiningBindings - , bindings - ) where - -import Control.DeepSeq -import Control.Monad -import Data.Bifunctor -import Data.IntervalMap.FingerTree (Interval (..), IntervalMap) -import qualified Data.IntervalMap.FingerTree as IM -import qualified Data.List as L -import qualified Data.Map as M -import qualified Data.Set as S -import Development.IDE.GHC.Compat (Name, RefMap, Scope (..), Type, - getBindSiteFromContext, - getScopeFromContext, identInfo, - identType, NameEnv, nameEnvElts, - unitNameEnv, isSystemName, - RealSrcSpan, realSrcSpanStart, - realSrcSpanEnd) - -import Development.IDE.GHC.Error -import Development.IDE.Types.Location - ------------------------------------------------------------------------------- --- | Turn a 'RealSrcSpan' into an 'Interval'. -realSrcSpanToInterval :: RealSrcSpan -> Interval Position -realSrcSpanToInterval rss = - Interval - (realSrcLocToPosition $ realSrcSpanStart rss) - (realSrcLocToPosition $ realSrcSpanEnd rss) - -bindings :: RefMap Type -> Bindings -bindings = uncurry Bindings . localBindings - ------------------------------------------------------------------------------- --- | Compute which identifiers are in scope at every point in the AST. Use --- 'getLocalScope' to find the results. -localBindings - :: RefMap Type - -> ( IntervalMap Position (NameEnv (Name, Maybe Type)) - , IntervalMap Position (NameEnv (Name, Maybe Type)) - ) -localBindings refmap = bimap mk mk $ unzip $ do - (ident, refs) <- M.toList refmap - Right name <- pure ident - (_, ident_details) <- refs - let ty = identType ident_details - info <- S.toList $ identInfo ident_details - pure - ( do - Just scopes <- pure $ getScopeFromContext info - scope <- scopes >>= \case - LocalScope scope -> pure $ realSrcSpanToInterval scope - _ -> [] - pure ( scope - , unitNameEnv name (name,ty) - ) - , do - Just scope <- pure $ getBindSiteFromContext info - pure ( realSrcSpanToInterval scope - , unitNameEnv name (name,ty) - ) - ) - where - mk = L.foldl' (flip (uncurry IM.insert)) mempty . join - ------------------------------------------------------------------------------- --- | The available bindings at every point in a Haskell tree. -data Bindings = Bindings - { getLocalBindings - :: IntervalMap Position (NameEnv (Name, Maybe Type)) - , getBindingSites - :: IntervalMap Position (NameEnv (Name, Maybe Type)) - } - -instance Semigroup Bindings where - Bindings a1 b1 <> Bindings a2 b2 - = Bindings (a1 <> a2) (b1 <> b2) - -instance Monoid Bindings where - mempty = Bindings mempty mempty - -instance NFData Bindings where - rnf = rwhnf - -instance Show Bindings where - show _ = "" - - ------------------------------------------------------------------------------- --- | Given a 'Bindings' get every identifier in scope at the given --- 'RealSrcSpan', -getLocalScope :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)] -getLocalScope bs rss - = nameEnvElts - $ foldMap snd - $ IM.dominators (realSrcSpanToInterval rss) - $ getLocalBindings bs - ------------------------------------------------------------------------------- --- | Given a 'Bindings', get every binding currently active at a given --- 'RealSrcSpan', -getDefiningBindings :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)] -getDefiningBindings bs rss - = nameEnvElts - $ foldMap snd - $ IM.dominators (realSrcSpanToInterval rss) - $ getBindingSites bs - - --- | Lookup all names in scope in any span that intersects the interval --- defined by the two positions. --- This is meant for use with the fuzzy `PositionRange` returned by `PositionMapping` -getFuzzyScope :: Bindings -> Position -> Position -> [(Name, Maybe Type)] -getFuzzyScope bs a b - = filter (not . isSystemName . fst) - $ nameEnvElts - $ foldMap snd - $ IM.intersections (Interval a b) - $ getLocalBindings bs - ------------------------------------------------------------------------------- --- | Given a 'Bindings', get every binding that intersects the interval defined --- by the two positions. --- This is meant for use with the fuzzy `PositionRange` returned by --- `PositionMapping` -getFuzzyDefiningBindings :: Bindings -> Position -> Position -> [(Name, Maybe Type)] -getFuzzyDefiningBindings bs a b - = nameEnvElts - $ foldMap snd - $ IM.intersections (Interval a b) - $ getBindingSites bs - +{-# LANGUAGE DerivingStrategies #-} + +module Development.IDE.Spans.LocalBindings + ( Bindings + , getLocalScope + , getFuzzyScope + , getDefiningBindings + , getFuzzyDefiningBindings + , bindings + ) where + +import Control.DeepSeq +import Control.Monad +import Data.Bifunctor +import Data.IntervalMap.FingerTree (Interval (..), IntervalMap) +import qualified Data.IntervalMap.FingerTree as IM +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Set as S +import Development.IDE.GHC.Compat (Name, NameEnv, RealSrcSpan, + RefMap, Scope (..), Type, + getBindSiteFromContext, + getScopeFromContext, identInfo, + identType, isSystemName, + nameEnvElts, realSrcSpanEnd, + realSrcSpanStart, unitNameEnv) + +import Development.IDE.GHC.Error +import Development.IDE.Types.Location + +------------------------------------------------------------------------------ +-- | Turn a 'RealSrcSpan' into an 'Interval'. +realSrcSpanToInterval :: RealSrcSpan -> Interval Position +realSrcSpanToInterval rss = + Interval + (realSrcLocToPosition $ realSrcSpanStart rss) + (realSrcLocToPosition $ realSrcSpanEnd rss) + +bindings :: RefMap Type -> Bindings +bindings = uncurry Bindings . localBindings + +------------------------------------------------------------------------------ +-- | Compute which identifiers are in scope at every point in the AST. Use +-- 'getLocalScope' to find the results. +localBindings + :: RefMap Type + -> ( IntervalMap Position (NameEnv (Name, Maybe Type)) + , IntervalMap Position (NameEnv (Name, Maybe Type)) + ) +localBindings refmap = bimap mk mk $ unzip $ do + (ident, refs) <- M.toList refmap + Right name <- pure ident + (_, ident_details) <- refs + let ty = identType ident_details + info <- S.toList $ identInfo ident_details + pure + ( do + Just scopes <- pure $ getScopeFromContext info + scope <- scopes >>= \case + LocalScope scope -> pure $ realSrcSpanToInterval scope + _ -> [] + pure ( scope + , unitNameEnv name (name,ty) + ) + , do + Just scope <- pure $ getBindSiteFromContext info + pure ( realSrcSpanToInterval scope + , unitNameEnv name (name,ty) + ) + ) + where + mk = L.foldl' (flip (uncurry IM.insert)) mempty . join + +------------------------------------------------------------------------------ +-- | The available bindings at every point in a Haskell tree. +data Bindings = Bindings + { getLocalBindings + :: IntervalMap Position (NameEnv (Name, Maybe Type)) + , getBindingSites + :: IntervalMap Position (NameEnv (Name, Maybe Type)) + } + +instance Semigroup Bindings where + Bindings a1 b1 <> Bindings a2 b2 + = Bindings (a1 <> a2) (b1 <> b2) + +instance Monoid Bindings where + mempty = Bindings mempty mempty + +instance NFData Bindings where + rnf = rwhnf + +instance Show Bindings where + show _ = "" + + +------------------------------------------------------------------------------ +-- | Given a 'Bindings' get every identifier in scope at the given +-- 'RealSrcSpan', +getLocalScope :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)] +getLocalScope bs rss + = nameEnvElts + $ foldMap snd + $ IM.dominators (realSrcSpanToInterval rss) + $ getLocalBindings bs + +------------------------------------------------------------------------------ +-- | Given a 'Bindings', get every binding currently active at a given +-- 'RealSrcSpan', +getDefiningBindings :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)] +getDefiningBindings bs rss + = nameEnvElts + $ foldMap snd + $ IM.dominators (realSrcSpanToInterval rss) + $ getBindingSites bs + + +-- | Lookup all names in scope in any span that intersects the interval +-- defined by the two positions. +-- This is meant for use with the fuzzy `PositionRange` returned by `PositionMapping` +getFuzzyScope :: Bindings -> Position -> Position -> [(Name, Maybe Type)] +getFuzzyScope bs a b + = filter (not . isSystemName . fst) + $ nameEnvElts + $ foldMap snd + $ IM.intersections (Interval a b) + $ getLocalBindings bs + +------------------------------------------------------------------------------ +-- | Given a 'Bindings', get every binding that intersects the interval defined +-- by the two positions. +-- This is meant for use with the fuzzy `PositionRange` returned by +-- `PositionMapping` +getFuzzyDefiningBindings :: Bindings -> Position -> Position -> [(Name, Maybe Type)] +getFuzzyDefiningBindings bs a b + = nameEnvElts + $ foldMap snd + $ IM.intersections (Interval a b) + $ getBindingSites bs + diff --git a/src/Development/IDE/Spans/Pragmas.hs b/src/Development/IDE/Spans/Pragmas.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Spans/Pragmas.hs @@ -0,0 +1,432 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE MultiWayIf #-} + +module Development.IDE.Spans.Pragmas + ( NextPragmaInfo(..) + , LineSplitTextEdits(..) + , getNextPragmaInfo ) where + +import Data.Bits (Bits (setBit)) +import Data.Function ((&)) +import qualified Data.List as List +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as Text +import Development.IDE (srcSpanToRange) +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.Util +import qualified Language.LSP.Types as LSP + +getNextPragmaInfo :: DynFlags -> Maybe Text -> NextPragmaInfo +getNextPragmaInfo dynFlags sourceText = + if | Just sourceText <- sourceText + , let sourceStringBuffer = stringToStringBuffer (Text.unpack sourceText) + , POk _ parserState <- parsePreDecl dynFlags sourceStringBuffer + -> case parserState of + ParserStateNotDone{ nextPragma } -> nextPragma + ParserStateDone{ nextPragma } -> nextPragma + | otherwise + -> NextPragmaInfo 0 Nothing + +-- Pre-declaration comments parser ----------------------------------------------------- + +-- | Each mode represents the "strongest" thing we've seen so far. +-- From strongest to weakest: +-- ModePragma, ModeHaddock, ModeComment, ModeInitial +data Mode = ModePragma | ModeHaddock | ModeComment | ModeInitial deriving Show + +data LineSplitTextEdits = LineSplitTextEdits { + lineSplitInsertTextEdit :: !LSP.TextEdit, + lineSplitDeleteTextEdit :: !LSP.TextEdit +} deriving Show + +data NextPragmaInfo = NextPragmaInfo { + nextPragmaLine :: !Int, + lineSplitTextEdits :: !(Maybe LineSplitTextEdits) +} deriving Show + +data ParserState + = ParserStateNotDone + { nextPragma :: !NextPragmaInfo + , mode :: !Mode + , lastBlockCommentLine :: !Int + , lastPragmaLine :: !Int + , isLastTokenHash :: !Bool + } + | ParserStateDone { nextPragma :: NextPragmaInfo } + deriving Show + +isPragma :: String -> Bool +isPragma = List.isPrefixOf "{-#" + +isDownwardBlockHaddock :: String -> Bool +isDownwardBlockHaddock = List.isPrefixOf "{-|" + +isDownwardLineHaddock :: String -> Bool +isDownwardLineHaddock = List.isPrefixOf "-- |" + +-- need to merge tokens that are deleted/inserted into one TextEdit each +-- to work around some weird TextEdits applied in reversed order issue +updateLineSplitTextEdits :: LSP.Range -> String -> Maybe LineSplitTextEdits -> LineSplitTextEdits +updateLineSplitTextEdits tokenRange tokenString prevLineSplitTextEdits + | Just prevLineSplitTextEdits <- prevLineSplitTextEdits + , let LineSplitTextEdits + { lineSplitInsertTextEdit = prevInsertTextEdit + , lineSplitDeleteTextEdit = prevDeleteTextEdit } = prevLineSplitTextEdits + , let LSP.TextEdit prevInsertRange prevInsertText = prevInsertTextEdit + , let LSP.TextEdit prevDeleteRange _prevDeleteText = prevDeleteTextEdit + , let LSP.Range prevInsertStartPos prevInsertEndPos = prevInsertRange + , let LSP.Position _prevInsertStartLine _prevInsertStartCol = prevInsertStartPos + , let LSP.Position _prevInsertEndLine _prevInsertEndCol = prevInsertEndPos + , let LSP.Range prevDeleteStartPos prevDeleteEndPos = prevDeleteRange + , let LSP.Position _prevDeleteStartLine _prevDeleteStartCol = prevDeleteStartPos + , let LSP.Position _prevDeleteEndLine prevDeleteEndCol = prevDeleteEndPos + , let currInsertRange = prevInsertRange + , let currInsertText = + Text.init prevInsertText + <> Text.replicate (fromIntegral $ startCol - prevDeleteEndCol) " " + <> Text.pack (List.take newLineCol tokenString) + <> "\n" + , let currInsertTextEdit = LSP.TextEdit currInsertRange currInsertText + , let currDeleteStartPos = prevDeleteStartPos + , let currDeleteEndPos = LSP.Position endLine endCol + , let currDeleteRange = LSP.Range currDeleteStartPos currDeleteEndPos + , let currDeleteTextEdit = LSP.TextEdit currDeleteRange "" + = LineSplitTextEdits currInsertTextEdit currDeleteTextEdit + | otherwise + , let LSP.Range startPos _ = tokenRange + , let deleteTextEdit = LSP.TextEdit (LSP.Range startPos startPos{ LSP._character = startCol + fromIntegral newLineCol }) "" + , let insertPosition = LSP.Position (startLine + 1) 0 + , let insertRange = LSP.Range insertPosition insertPosition + , let insertText = Text.pack (List.take newLineCol tokenString) <> "\n" + , let insertTextEdit = LSP.TextEdit insertRange insertText + = LineSplitTextEdits insertTextEdit deleteTextEdit + where + LSP.Range (LSP.Position startLine startCol) (LSP.Position endLine endCol) = tokenRange + + newLineCol = Maybe.fromMaybe (length tokenString) (List.elemIndex '\n' tokenString) + +-- ITvarsym "#" after a block comment is a parse error so we don't need to worry about it +updateParserState :: Token -> LSP.Range -> ParserState -> ParserState +updateParserState token range prevParserState + | ParserStateNotDone + { nextPragma = prevNextPragma@NextPragmaInfo{ lineSplitTextEdits = prevLineSplitTextEdits } + , mode = prevMode + , lastBlockCommentLine + , lastPragmaLine + } <- prevParserState + , let defaultParserState = prevParserState { isLastTokenHash = False } + , let LSP.Range (LSP.Position (fromIntegral -> startLine) _) (LSP.Position (fromIntegral -> endLine) _) = range + = case prevMode of + ModeInitial -> + case token of + ITvarsym "#" -> defaultParserState{ isLastTokenHash = True } +#if !MIN_VERSION_ghc(9,2,0) + ITlineComment s +#else + ITlineComment s _ +#endif + | isDownwardLineHaddock s -> defaultParserState{ mode = ModeHaddock } + | otherwise -> + defaultParserState + { nextPragma = NextPragmaInfo (endLine + 1) Nothing + , mode = ModeComment } +#if !MIN_VERSION_ghc(9,2,0) + ITblockComment s +#else + ITblockComment s _ +#endif + | isPragma s -> + defaultParserState + { nextPragma = NextPragmaInfo (endLine + 1) Nothing + , mode = ModePragma + , lastPragmaLine = endLine } + | isDownwardBlockHaddock s -> defaultParserState{ mode = ModeHaddock } + | otherwise -> + defaultParserState + { nextPragma = NextPragmaInfo (endLine + 1) Nothing + , mode = ModeComment + , lastBlockCommentLine = endLine } + _ -> ParserStateDone prevNextPragma + ModeComment -> + case token of + ITvarsym "#" -> defaultParserState{ isLastTokenHash = True } +#if !MIN_VERSION_ghc(9,2,0) + ITlineComment s +#else + ITlineComment s _ +#endif + | hasDeleteStartedOnSameLine startLine prevLineSplitTextEdits + , let currLineSplitTextEdits = updateLineSplitTextEdits range s prevLineSplitTextEdits -> + defaultParserState{ nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } } + | isDownwardLineHaddock s + , lastBlockCommentLine == startLine + , let currLineSplitTextEdits = updateLineSplitTextEdits range s Nothing -> + defaultParserState + { nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } + , mode = ModeHaddock } + | otherwise -> + defaultParserState { nextPragma = NextPragmaInfo (endLine + 1) Nothing } +#if !MIN_VERSION_ghc(9,2,0) + ITblockComment s +#else + ITblockComment s _ +#endif + | isPragma s -> + defaultParserState + { nextPragma = NextPragmaInfo (endLine + 1) Nothing + , mode = ModePragma + , lastPragmaLine = endLine } + | hasDeleteStartedOnSameLine startLine prevLineSplitTextEdits + , let currLineSplitTextEdits = updateLineSplitTextEdits range s prevLineSplitTextEdits -> + defaultParserState{ nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } } + | isDownwardBlockHaddock s + , lastBlockCommentLine == startLine + , let currLineSplitTextEdits = updateLineSplitTextEdits range s Nothing -> + defaultParserState{ + nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits }, + mode = ModeHaddock } + | otherwise -> + defaultParserState{ + nextPragma = NextPragmaInfo (endLine + 1) Nothing, + lastBlockCommentLine = endLine } + _ -> ParserStateDone prevNextPragma + ModeHaddock -> + case token of + ITvarsym "#" -> + defaultParserState{ isLastTokenHash = True } +#if !MIN_VERSION_ghc(9,2,0) + ITlineComment s +#else + ITlineComment s _ +#endif + | hasDeleteStartedOnSameLine startLine prevLineSplitTextEdits + , let currLineSplitTextEdits = updateLineSplitTextEdits range s prevLineSplitTextEdits -> + defaultParserState{ nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } } + | otherwise -> + defaultParserState +#if !MIN_VERSION_ghc(9,2,0) + ITblockComment s +#else + ITblockComment s _ +#endif + | isPragma s -> + defaultParserState{ + nextPragma = NextPragmaInfo (endLine + 1) Nothing, + mode = ModePragma, + lastPragmaLine = endLine } + | hasDeleteStartedOnSameLine startLine prevLineSplitTextEdits + , let currLineSplitTextEdits = updateLineSplitTextEdits range s prevLineSplitTextEdits -> + defaultParserState{ nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } } + | otherwise -> defaultParserState{ lastBlockCommentLine = endLine } + _ -> ParserStateDone prevNextPragma + ModePragma -> + case token of + ITvarsym "#" -> defaultParserState{ isLastTokenHash = True } +#if !MIN_VERSION_ghc(9,2,0) + ITlineComment s +#else + ITlineComment s _ +#endif + | hasDeleteStartedOnSameLine startLine prevLineSplitTextEdits + , let currLineSplitTextEdits = updateLineSplitTextEdits range s prevLineSplitTextEdits -> + defaultParserState{ nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } } + | isDownwardLineHaddock s + , lastPragmaLine == startLine + , let currLineSplitTextEdits = updateLineSplitTextEdits range s Nothing -> + defaultParserState{ nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } } + | otherwise -> + defaultParserState +#if !MIN_VERSION_ghc(9,2,0) + ITblockComment s +#else + ITblockComment s _ +#endif + | isPragma s -> + defaultParserState{ nextPragma = NextPragmaInfo (endLine + 1) Nothing, lastPragmaLine = endLine } + | hasDeleteStartedOnSameLine startLine prevLineSplitTextEdits + , let currLineSplitTextEdits = updateLineSplitTextEdits range s prevLineSplitTextEdits -> + defaultParserState{ nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } } + | isDownwardBlockHaddock s + , lastPragmaLine == startLine + , let currLineSplitTextEdits = updateLineSplitTextEdits range s Nothing -> + defaultParserState{ nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } } + | lastPragmaLine == startLine && startLine < endLine + , let currLineSplitTextEdits = updateLineSplitTextEdits range s Nothing -> + defaultParserState{ nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } } + | otherwise -> + defaultParserState{ lastBlockCommentLine = endLine } + _ -> ParserStateDone prevNextPragma + | otherwise = prevParserState + where + hasDeleteStartedOnSameLine :: Int -> Maybe LineSplitTextEdits -> Bool + hasDeleteStartedOnSameLine line lineSplitTextEdits + | Just lineSplitTextEdits <- lineSplitTextEdits + , let LineSplitTextEdits{ lineSplitDeleteTextEdit } = lineSplitTextEdits + , let LSP.TextEdit deleteRange _ = lineSplitDeleteTextEdit + , let LSP.Range _ deleteEndPosition = deleteRange + , let LSP.Position deleteEndLine _ = deleteEndPosition + = fromIntegral deleteEndLine == line + | otherwise = False + +lexUntilNextLineIncl :: P (Located Token) +lexUntilNextLineIncl = do + PState{ last_loc } <- getPState +#if MIN_VERSION_ghc(9,0,0) + let PsSpan{ psRealSpan = lastRealSrcSpan } = last_loc +#else + let lastRealSrcSpan = last_loc +#endif + let prevEndLine = lastRealSrcSpan & realSrcSpanEnd & srcLocLine + locatedToken@(L srcSpan _token) <- lexer False pure + if | RealSrcLoc currEndRealSrcLoc _ <- srcSpan & srcSpanEnd + , let currEndLine = currEndRealSrcLoc & srcLocLine + -> if prevEndLine < currEndLine then + pure locatedToken + else lexUntilNextLineIncl + | otherwise -> pure locatedToken + +dropWhileStringBuffer :: (Char -> Bool) -> StringBuffer -> StringBuffer +dropWhileStringBuffer predicate buffer + | atEnd buffer = buffer + | let (c, remainingBuffer) = nextChar buffer + = if predicate c then + dropWhileStringBuffer predicate remainingBuffer + else + buffer + +isHorizontalSpace :: Char -> Bool +isHorizontalSpace c = c == ' ' || c == '\t' + +data ShebangParserState = ShebangParserState { + nextPragmaLine :: !Int, + newlineCount :: !Int, + prevCharIsHash :: !Bool, + buffer :: !StringBuffer +} + +-- lexer seems to ignore shebangs completely hence this function +parseShebangs :: ShebangParserState -> ShebangParserState +parseShebangs prev@ShebangParserState{ newlineCount = prevNewlineCount, prevCharIsHash, buffer = prevBuffer } + | atEnd prevBuffer + = prev + | let (c, currBuffer) = nextChar (dropWhileStringBuffer isHorizontalSpace prevBuffer) + = if c == '#' then + parseShebangs prev{ prevCharIsHash = True, buffer = currBuffer } + else if c == '!' && prevCharIsHash then + parseShebangs prev{ nextPragmaLine = prevNewlineCount + 1, buffer = dropWhileStringBuffer (/= '\n') currBuffer } + else if c == '\n' then + parseShebangs prev{ newlineCount = prevNewlineCount + 1, buffer = currBuffer } + else + prev + + +-- | Parses blank lines, comments, haddock comments ("-- |"), lines that start +-- with "#!", lines that start with "#", pragma lines using the GHC API lexer. +-- When it doesn't find one of these things then it's assumed that we've found +-- a declaration, end-of-file, or a ghc parse error, and the parser stops. +-- Shebangs are parsed separately than the rest becaues the lexer ignores them. +-- +-- The reason for custom parsing instead of using annotations, or turning on/off +-- extensions in the dynflags is because there are a number of extensions that +-- while removing parse errors, can also introduce them. Hence, there are +-- cases where the file cannot be parsed without error when we want to insert +-- extension (and other) pragmas. The compiler (8.10.7) doesn't include +-- annotations in its failure state. So if the compiler someday returns +-- annotation or equivalent information when it fails then we can replace this +-- with that. +-- +-- The reason for using the compiler lexer is to reduce duplicated +-- implementation, particularly nested comments, but in retrospect this comes +-- with the disadvantage of the logic feeling more complex, and not being able +-- to handle whitespace directly. +-- +-- The parser keeps track of state in order to place the next pragma line +-- according to some rules: +-- +-- - Ignore lines starting with '#' except for shebangs. +-- - If pragmas exist place after last pragma +-- - else if haddock comments exist: +-- - If comments exist place after last comment +-- - else if shebangs exist place after last shebang +-- - else place at first line +-- - else if comments exist place after last comment +-- - else if shebangs exist place after last shebang +-- - else place at first line +-- +-- Additionally the parser keeps track of information to be able to insert +-- pragmas inbetween lines. +-- +-- For example the parser keeps track of information so that +-- +-- > {- block comment -} -- | haddock +-- +-- can become +-- +-- > {- block comment -} +-- > {-# pragma #-} +-- > -- | haddock +-- +-- This information does not respect the type of whitespace, because the lexer +-- strips whitespace and gives locations. +-- +-- In this example the tabs are converted to spaces in the TextEdits: +-- +-- > {- block comment -}-- | haddock +-- +parsePreDecl :: DynFlags -> StringBuffer -> ParseResult ParserState +parsePreDecl dynFlags buffer = unP (go initialParserState) pState + where + initialShebangParserState = ShebangParserState{ + nextPragmaLine = 0, + newlineCount = 0, + prevCharIsHash = False, + buffer = buffer } + ShebangParserState{ nextPragmaLine } = parseShebangs initialShebangParserState + pState = mkLexerPState dynFlags buffer + initialParserState = ParserStateNotDone (NextPragmaInfo nextPragmaLine Nothing) ModeInitial (-1) (-1) False + + go :: ParserState -> P ParserState + go prevParserState = + case prevParserState of + ParserStateDone _ -> pure prevParserState + ParserStateNotDone{..} -> do + L srcSpan token <- + if isLastTokenHash then + lexUntilNextLineIncl + else + lexer False pure + case srcSpanToRange srcSpan of + Just range -> go (updateParserState token range prevParserState) + Nothing -> pure prevParserState + +mkLexerPState :: DynFlags -> StringBuffer -> PState +mkLexerPState dynFlags stringBuffer = + let + startRealSrcLoc = mkRealSrcLoc "asdf" 1 1 + updateDynFlags = flip gopt_unset Opt_Haddock . flip gopt_set Opt_KeepRawTokenStream + finalDynFlags = updateDynFlags dynFlags +#if !MIN_VERSION_ghc(8,8,1) + pState = mkPState finalDynFlags stringBuffer startRealSrcLoc + finalPState = pState{ use_pos_prags = False } +#elif !MIN_VERSION_ghc(8,10,1) + mkLexerParserFlags = + mkParserFlags' + <$> warningFlags + <*> extensionFlags + <*> homeUnitId_ + <*> safeImportsOn + <*> gopt Opt_Haddock + <*> gopt Opt_KeepRawTokenStream + <*> const False + finalPState = mkPStatePure (mkLexerParserFlags finalDynFlags) stringBuffer startRealSrcLoc +#else + pState = initParserState (initParserOpts finalDynFlags) stringBuffer startRealSrcLoc + PState{ options = pStateOptions } = pState + finalExtBitsMap = setBit (pExtsBitmap pStateOptions) (fromEnum UsePosPragsBit) + finalPStateOptions = pStateOptions{ pExtsBitmap = finalExtBitsMap } + finalPState = pState{ options = finalPStateOptions } +#endif + in + finalPState diff --git a/src/Development/IDE/Types/Diagnostics.hs b/src/Development/IDE/Types/Diagnostics.hs --- a/src/Development/IDE/Types/Diagnostics.hs +++ b/src/Development/IDE/Types/Diagnostics.hs @@ -92,7 +92,7 @@ prettyRange :: Range -> Doc Terminal.AnsiStyle prettyRange Range{..} = f _start <> "-" <> f _end - where f Position{..} = pretty (_line+1) <> colon <> pretty (_character+1) + where f Position{..} = pretty (show $ _line+1) <> colon <> pretty (show $ _character+1) stringParagraphs :: T.Text -> Doc a stringParagraphs = vcat . map (fillSep . map pretty . T.words) . T.lines diff --git a/src/Development/IDE/Types/Exports.hs b/src/Development/IDE/Types/Exports.hs --- a/src/Development/IDE/Types/Exports.hs +++ b/src/Development/IDE/Types/Exports.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE RankNTypes #-} module Development.IDE.Types.Exports ( IdentInfo(..), @@ -26,6 +27,7 @@ import Development.IDE.GHC.Compat import Development.IDE.GHC.Orphans () import Development.IDE.GHC.Util +import Development.IDE.Types.Shake (WithHieDb) import GHC.Generics (Generic) import HieDb @@ -154,13 +156,13 @@ nonInternalModules :: ModuleName -> Bool nonInternalModules = not . (".Internal" `isSuffixOf`) . moduleNameString -createExportsMapHieDb :: HieDb -> IO ExportsMap -createExportsMapHieDb hiedb = do - mods <- getAllIndexedMods hiedb +createExportsMapHieDb :: WithHieDb -> IO ExportsMap +createExportsMapHieDb withHieDb = do + mods <- withHieDb getAllIndexedMods idents <- forM (filter (nonInternalModules . modInfoName . hieModInfo) mods) $ \m -> do let mn = modInfoName $ hieModInfo m mText = pack $ moduleNameString mn - fmap (wrap . unwrap mText) <$> getExportsForModule hiedb mn + fmap (wrap . unwrap mText) <$> withHieDb (\hieDb -> getExportsForModule hieDb mn) let exportsMap = Map.fromListWith (<>) (concat idents) return $ ExportsMap exportsMap $ buildModuleExportMap (concat idents) where diff --git a/src/Development/IDE/Types/HscEnvEq.hs b/src/Development/IDE/Types/HscEnvEq.hs --- a/src/Development/IDE/Types/HscEnvEq.hs +++ b/src/Development/IDE/Types/HscEnvEq.hs @@ -1,151 +1,153 @@ -module Development.IDE.Types.HscEnvEq -( HscEnvEq, - hscEnv, newHscEnvEq, - hscEnvWithImportPaths, - newHscEnvEqPreserveImportPaths, - newHscEnvEqWithImportPaths, - envImportPaths, - envPackageExports, - envVisibleModuleNames, - deps -) where - - -import Control.Concurrent.Async (Async, async, waitCatch) -import Control.Concurrent.Strict (modifyVar, newVar) -import Control.DeepSeq (force) -import Control.Exception (evaluate, mask, throwIO) -import Control.Monad.Extra (eitherM, join, mapMaybeM) -import Control.Monad.IO.Class -import Data.Either (fromRight) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Unique (Unique) -import qualified Data.Unique as Unique -import Development.IDE.GHC.Compat -import qualified Development.IDE.GHC.Compat.Util as Maybes -import Development.IDE.GHC.Error (catchSrcErrors) -import Development.IDE.GHC.Util (lookupPackageConfig) -import Development.IDE.Graph.Classes -import Development.IDE.Types.Exports (ExportsMap, createExportsMap) -import OpenTelemetry.Eventlog (withSpan) -import System.Directory (canonicalizePath) -import System.FilePath - --- | An 'HscEnv' with equality. Two values are considered equal --- if they are created with the same call to 'newHscEnvEq'. -data HscEnvEq = HscEnvEq - { envUnique :: !Unique - , hscEnv :: !HscEnv - , deps :: [(UnitId, DynFlags)] - -- ^ In memory components for this HscEnv - -- This is only used at the moment for the import dirs in - -- the DynFlags - , envImportPaths :: Maybe (Set FilePath) - -- ^ If Just, import dirs originally configured in this env - -- If Nothing, the env import dirs are unaltered - , envPackageExports :: IO ExportsMap - , envVisibleModuleNames :: IO (Maybe [ModuleName]) - -- ^ 'listVisibleModuleNames' is a pure function, - -- but it could panic due to a ghc bug: https://github.com/haskell/haskell-language-server/issues/1365 - -- So it's wrapped in IO here for error handling - -- If Nothing, 'listVisibleModuleNames' panic - } - --- | Wrap an 'HscEnv' into an 'HscEnvEq'. -newHscEnvEq :: FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq -newHscEnvEq cradlePath hscEnv0 deps = do - let relativeToCradle = (takeDirectory cradlePath ) - hscEnv = removeImportPaths hscEnv0 - - -- Canonicalize import paths since we also canonicalize targets - importPathsCanon <- - mapM canonicalizePath $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0) - - newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) hscEnv deps - -newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq -newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do - - let dflags = hsc_dflags hscEnv - - envUnique <- Unique.newUnique - - -- it's very important to delay the package exports computation - envPackageExports <- onceAsync $ withSpan "Package Exports" $ \_sp -> do - -- compute the package imports - let pkgst = unitState hscEnv - depends = explicitUnits pkgst - targets = - [ (pkg, mn) - | d <- depends - , Just pkg <- [lookupPackageConfig d hscEnv] - , (mn, _) <- unitExposedModules pkg - ] - - doOne (pkg, mn) = do - modIface <- liftIO $ initIfaceLoad hscEnv $ loadInterface - "" - (mkModule (unitInfoId pkg) mn) - (ImportByUser NotBoot) - return $ case modIface of - Maybes.Failed _r -> Nothing - Maybes.Succeeded mi -> Just mi - modIfaces <- mapMaybeM doOne targets - return $ createExportsMap modIfaces - - -- similar to envPackageExports, evaluated lazily - envVisibleModuleNames <- onceAsync $ - fromRight Nothing - <$> catchSrcErrors - dflags - "listVisibleModuleNames" - (evaluate . force . Just $ listVisibleModuleNames hscEnv) - - return HscEnvEq{..} - --- | Wrap an 'HscEnv' into an 'HscEnvEq'. -newHscEnvEqPreserveImportPaths - :: HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq -newHscEnvEqPreserveImportPaths = newHscEnvEqWithImportPaths Nothing - --- | Unwrap the 'HscEnv' with the original import paths. --- Used only for locating imports -hscEnvWithImportPaths :: HscEnvEq -> HscEnv -hscEnvWithImportPaths HscEnvEq{..} - | Just imps <- envImportPaths - = hscSetFlags (setImportPaths (Set.toList imps) (hsc_dflags hscEnv)) hscEnv - | otherwise - = hscEnv - -removeImportPaths :: HscEnv -> HscEnv -removeImportPaths hsc = hscSetFlags (setImportPaths [] (hsc_dflags hsc)) hsc - -instance Show HscEnvEq where - show HscEnvEq{envUnique} = "HscEnvEq " ++ show (Unique.hashUnique envUnique) - -instance Eq HscEnvEq where - a == b = envUnique a == envUnique b - -instance NFData HscEnvEq where - rnf (HscEnvEq a b c d _ _) = - -- deliberately skip the package exports map and visible module names - rnf (Unique.hashUnique a) `seq` b `seq` c `seq` rnf d - -instance Hashable HscEnvEq where - hashWithSalt s = hashWithSalt s . envUnique - --- | Given an action, produce a wrapped action that runs at most once. --- The action is run in an async so it won't be killed by async exceptions --- If the function raises an exception, the same exception will be reraised each time. -onceAsync :: IO a -> IO (IO a) -onceAsync act = do - var <- newVar OncePending - let run as = eitherM throwIO pure (waitCatch as) - pure $ mask $ \unmask -> join $ modifyVar var $ \v -> case v of - OnceRunning x -> pure (v, unmask $ run x) - OncePending -> do - x <- async (unmask act) - pure (OnceRunning x, unmask $ run x) - -data Once a = OncePending | OnceRunning (Async a) +module Development.IDE.Types.HscEnvEq +( HscEnvEq, + hscEnv, newHscEnvEq, + hscEnvWithImportPaths, + newHscEnvEqPreserveImportPaths, + newHscEnvEqWithImportPaths, + envImportPaths, + envPackageExports, + envVisibleModuleNames, + deps +) where + + +import Control.Concurrent.Async (Async, async, waitCatch) +import Control.Concurrent.Strict (modifyVar, newVar) +import Control.DeepSeq (force) +import Control.Exception (evaluate, mask, throwIO) +import Control.Monad.Extra (eitherM, join, mapMaybeM) +import Data.Either (fromRight) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Unique (Unique) +import qualified Data.Unique as Unique +import Development.IDE.GHC.Compat +import qualified Development.IDE.GHC.Compat.Util as Maybes +import Development.IDE.GHC.Error (catchSrcErrors) +import Development.IDE.GHC.Util (lookupPackageConfig) +import Development.IDE.Graph.Classes +import Development.IDE.Types.Exports (ExportsMap, createExportsMap) +import OpenTelemetry.Eventlog (withSpan) +import System.Directory (makeAbsolute) +import System.FilePath + +-- | An 'HscEnv' with equality. Two values are considered equal +-- if they are created with the same call to 'newHscEnvEq'. +data HscEnvEq = HscEnvEq + { envUnique :: !Unique + , hscEnv :: !HscEnv + , deps :: [(UnitId, DynFlags)] + -- ^ In memory components for this HscEnv + -- This is only used at the moment for the import dirs in + -- the DynFlags + , envImportPaths :: Maybe (Set FilePath) + -- ^ If Just, import dirs originally configured in this env + -- If Nothing, the env import dirs are unaltered + , envPackageExports :: IO ExportsMap + , envVisibleModuleNames :: IO (Maybe [ModuleName]) + -- ^ 'listVisibleModuleNames' is a pure function, + -- but it could panic due to a ghc bug: https://github.com/haskell/haskell-language-server/issues/1365 + -- So it's wrapped in IO here for error handling + -- If Nothing, 'listVisibleModuleNames' panic + } + +-- | Wrap an 'HscEnv' into an 'HscEnvEq'. +newHscEnvEq :: FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq +newHscEnvEq cradlePath hscEnv0 deps = do + let relativeToCradle = (takeDirectory cradlePath ) + hscEnv = removeImportPaths hscEnv0 + + -- Make Absolute since targets are also absolute + importPathsCanon <- + mapM makeAbsolute $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0) + + newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) hscEnv deps + +newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq +newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do + + let dflags = hsc_dflags hscEnv + + envUnique <- Unique.newUnique + + -- it's very important to delay the package exports computation + envPackageExports <- onceAsync $ withSpan "Package Exports" $ \_sp -> do + -- compute the package imports + let pkgst = unitState hscEnv + depends = explicitUnits pkgst + modules = + [ m + | d <- depends + , Just pkg <- [lookupPackageConfig d hscEnv] + , (modName, maybeOtherPkgMod) <- unitExposedModules pkg + , let m = case maybeOtherPkgMod of + -- When module is re-exported from another package, + -- the origin module is represented by value in Just + Just otherPkgMod -> otherPkgMod + Nothing -> mkModule (unitInfoId pkg) modName + ] + + doOne m = do + modIface <- initIfaceLoad hscEnv $ + loadInterface "" m (ImportByUser NotBoot) + return $ case modIface of + Maybes.Failed _r -> Nothing + Maybes.Succeeded mi -> Just mi + modIfaces <- mapMaybeM doOne modules + return $ createExportsMap modIfaces + + -- similar to envPackageExports, evaluated lazily + envVisibleModuleNames <- onceAsync $ + fromRight Nothing + <$> catchSrcErrors + dflags + "listVisibleModuleNames" + (evaluate . force . Just $ listVisibleModuleNames hscEnv) + + return HscEnvEq{..} + +-- | Wrap an 'HscEnv' into an 'HscEnvEq'. +newHscEnvEqPreserveImportPaths + :: HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq +newHscEnvEqPreserveImportPaths = newHscEnvEqWithImportPaths Nothing + +-- | Unwrap the 'HscEnv' with the original import paths. +-- Used only for locating imports +hscEnvWithImportPaths :: HscEnvEq -> HscEnv +hscEnvWithImportPaths HscEnvEq{..} + | Just imps <- envImportPaths + = hscSetFlags (setImportPaths (Set.toList imps) (hsc_dflags hscEnv)) hscEnv + | otherwise + = hscEnv + +removeImportPaths :: HscEnv -> HscEnv +removeImportPaths hsc = hscSetFlags (setImportPaths [] (hsc_dflags hsc)) hsc + +instance Show HscEnvEq where + show HscEnvEq{envUnique} = "HscEnvEq " ++ show (Unique.hashUnique envUnique) + +instance Eq HscEnvEq where + a == b = envUnique a == envUnique b + +instance NFData HscEnvEq where + rnf (HscEnvEq a b c d _ _) = + -- deliberately skip the package exports map and visible module names + rnf (Unique.hashUnique a) `seq` b `seq` c `seq` rnf d + +instance Hashable HscEnvEq where + hashWithSalt s = hashWithSalt s . envUnique + +-- | Given an action, produce a wrapped action that runs at most once. +-- The action is run in an async so it won't be killed by async exceptions +-- If the function raises an exception, the same exception will be reraised each time. +onceAsync :: IO a -> IO (IO a) +onceAsync act = do + var <- newVar OncePending + let run as = eitherM throwIO pure (waitCatch as) + pure $ mask $ \unmask -> join $ modifyVar var $ \v -> case v of + OnceRunning x -> pure (v, unmask $ run x) + OncePending -> do + x <- async (unmask act) + pure (OnceRunning x, unmask $ run x) + +data Once a = OncePending | OnceRunning (Async a) diff --git a/src/Development/IDE/Types/Logger.hs b/src/Development/IDE/Types/Logger.hs --- a/src/Development/IDE/Types/Logger.hs +++ b/src/Development/IDE/Types/Logger.hs @@ -31,7 +31,7 @@ -- | Note that this is logging actions _of the program_, not of the user. -- You shouldn't call warning/error if the user has caused an error, only -- if our code has gone wrong and is itself erroneous (e.g. we threw an exception). -data Logger = Logger {logPriority :: Priority -> T.Text -> IO ()} +newtype Logger = Logger {logPriority :: Priority -> T.Text -> IO ()} instance Semigroup Logger where l1 <> l2 = Logger $ \p t -> logPriority l1 p t >> logPriority l2 p t diff --git a/src/Development/IDE/Types/Shake.hs b/src/Development/IDE/Types/Shake.hs --- a/src/Development/IDE/Types/Shake.hs +++ b/src/Development/IDE/Types/Shake.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} module Development.IDE.Types.Shake ( Q (..), @@ -13,14 +14,13 @@ ShakeValue(..), currentValue, isBadDependency, - toShakeValue,encodeShakeValue,decodeShakeValue,toKey,toNoFileKey,fromKey,fromKeyType) + toShakeValue,encodeShakeValue,decodeShakeValue,toKey,toNoFileKey,fromKey,fromKeyType,WithHieDb) where import Control.DeepSeq import Control.Exception import qualified Data.ByteString.Char8 as BS import Data.Dynamic -import Data.HashMap.Strict import Data.Hashable import Data.Typeable (cast) import Data.Vector (Vector) @@ -30,13 +30,19 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import GHC.Generics +import HieDb.Types (HieDb) import Language.LSP.Types +import qualified StmContainers.Map as STM import Type.Reflection (SomeTypeRep (SomeTypeRep), pattern App, pattern Con, typeOf, typeRep, typeRepTyCon) import Unsafe.Coerce (unsafeCoerce) +-- | Intended to represent HieDb calls wrapped with (currently) retry +-- functionality +type WithHieDb = forall a. (HieDb -> IO a) -> IO a + data Value v = Succeeded TextDocumentVersion v | Stale (Maybe PositionDelta) TextDocumentVersion v @@ -56,7 +62,7 @@ = ValueWithDiagnostics !(Value Dynamic) !(Vector FileDiagnostic) -- | The state of the all values and diagnostics -type Values = HashMap Key ValueWithDiagnostics +type Values = STM.Map Key ValueWithDiagnostics -- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency -- which short-circuits the rest of the action diff --git a/src/Generics/SYB/GHC.hs b/src/Generics/SYB/GHC.hs --- a/src/Generics/SYB/GHC.hs +++ b/src/Generics/SYB/GHC.hs @@ -1,124 +1,124 @@ -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE RankNTypes #-} - --- | Custom SYB traversals explicitly designed for operating over the GHC AST. -module Generics.SYB.GHC - ( genericIsSubspan, - mkBindListT, - everywhereM', - smallestM, - largestM - ) where - -import Control.Monad -import Data.Functor.Compose (Compose (Compose)) -import Data.Monoid (Any (Any)) -import Development.IDE.GHC.Compat -import Development.IDE.Graph.Classes -import Generics.SYB - - --- | A generic query intended to be used for calling 'smallestM' and --- 'largestM'. If the current node is a 'Located', returns whether or not the --- given 'SrcSpan' is a subspan. For all other nodes, returns 'Nothing', which --- indicates uncertainty. The search strategy in 'smallestM' et al. will --- continue searching uncertain nodes. -genericIsSubspan :: - forall ast. - Typeable ast => - -- | The type of nodes we'd like to consider. - Proxy (Located ast) -> - SrcSpan -> - GenericQ (Maybe (Bool, ast)) -genericIsSubspan _ dst = mkQ Nothing $ \case - (L span ast :: Located ast) -> Just (dst `isSubspanOf` span, ast) - - --- | Lift a function that replaces a value with several values into a generic --- function. The result doesn't perform any searching, so should be driven via --- 'everywhereM' or friends. --- --- The 'Int' argument is the index in the list being bound. -mkBindListT :: forall b m. (Data b, Monad m) => (Int -> b -> m [b]) -> GenericM m -mkBindListT f = mkM $ fmap join . traverse (uncurry f) . zip [0..] - - --- | Apply a monadic transformation everywhere in a top-down manner. -everywhereM' :: forall m. Monad m => GenericM m -> GenericM m -everywhereM' f = go - where - go :: GenericM m - go = gmapM go <=< f - - ------------------------------------------------------------------------------- --- Custom SYB machinery ------------------------------------------------------------------------------- - --- | Generic monadic transformations that return side-channel data. -type GenericMQ r m = forall a. Data a => a -> m (r, a) - ------------------------------------------------------------------------------- --- | Apply the given 'GenericM' at all every node whose children fail the --- 'GenericQ', but which passes the query itself. --- --- The query must be a monotonic function when it returns 'Just'. That is, if --- @s@ is a subtree of @t@, @q t@ should return @Just True@ if @q s@ does. It --- is the True-to-false edge of the query that triggers the transformation. --- --- Why is the query a @Maybe Bool@? The GHC AST intersperses 'Located' nodes --- with data nodes, so for any given node we can only definitely return an --- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is --- used. -smallestM :: forall m a. Monad m => GenericQ (Maybe (Bool, a)) -> (a -> GenericM m) -> GenericM m -smallestM q f = fmap snd . go - where - go :: GenericMQ Any m - go x = do - case q x of - Nothing -> gmapMQ go x - Just (True, a) -> do - it@(r, x') <- gmapMQ go x - case r of - Any True -> pure it - Any False -> fmap (Any True,) $ f a x' - Just (False, _) -> pure (mempty, x) - ------------------------------------------------------------------------------- --- | Apply the given 'GenericM' at every node that passes the 'GenericQ', but --- don't descend into children if the query matches. Because this traversal is --- root-first, this policy will find the largest subtrees for which the query --- holds true. --- --- Why is the query a @Maybe Bool@? The GHC AST intersperses 'Located' nodes --- with data nodes, so for any given node we can only definitely return an --- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is --- used. -largestM :: forall m a. Monad m => GenericQ (Maybe (Bool, a)) -> (a -> GenericM m) -> GenericM m -largestM q f = go - where - go :: GenericM m - go x = do - case q x of - Just (True, a) -> f a x - Just (False, _) -> pure x - Nothing -> gmapM go x - -newtype MonadicQuery r m a = MonadicQuery - { runMonadicQuery :: m (r, a) - } - deriving stock (Functor) - deriving Applicative via Compose m ((,) r) - - ------------------------------------------------------------------------------- --- | Like 'gmapM', but also returns side-channel data. -gmapMQ :: - forall f r a. (Monoid r, Data a, Applicative f) => - (forall d. Data d => d -> f (r, d)) -> - a -> - f (r, a) -gmapMQ f = runMonadicQuery . gfoldl k pure - where - k :: Data d => MonadicQuery r f (d -> b) -> d -> MonadicQuery r f b - k c x = c <*> MonadicQuery (f x) +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE RankNTypes #-} + +-- | Custom SYB traversals explicitly designed for operating over the GHC AST. +module Generics.SYB.GHC + ( genericIsSubspan, + mkBindListT, + everywhereM', + smallestM, + largestM + ) where + +import Control.Monad +import Data.Functor.Compose (Compose (Compose)) +import Data.Monoid (Any (Any)) +import Development.IDE.GHC.Compat +import Development.IDE.Graph.Classes +import Generics.SYB + + +-- | A generic query intended to be used for calling 'smallestM' and +-- 'largestM'. If the current node is a 'Located', returns whether or not the +-- given 'SrcSpan' is a subspan. For all other nodes, returns 'Nothing', which +-- indicates uncertainty. The search strategy in 'smallestM' et al. will +-- continue searching uncertain nodes. +genericIsSubspan :: + forall ast. + Typeable ast => + -- | The type of nodes we'd like to consider. + Proxy (Located ast) -> + SrcSpan -> + GenericQ (Maybe (Bool, ast)) +genericIsSubspan _ dst = mkQ Nothing $ \case + (L span ast :: Located ast) -> Just (dst `isSubspanOf` span, ast) + + +-- | Lift a function that replaces a value with several values into a generic +-- function. The result doesn't perform any searching, so should be driven via +-- 'everywhereM' or friends. +-- +-- The 'Int' argument is the index in the list being bound. +mkBindListT :: forall b m. (Data b, Monad m) => (Int -> b -> m [b]) -> GenericM m +mkBindListT f = mkM $ fmap join . traverse (uncurry f) . zip [0..] + + +-- | Apply a monadic transformation everywhere in a top-down manner. +everywhereM' :: forall m. Monad m => GenericM m -> GenericM m +everywhereM' f = go + where + go :: GenericM m + go = gmapM go <=< f + + +------------------------------------------------------------------------------ +-- Custom SYB machinery +------------------------------------------------------------------------------ + +-- | Generic monadic transformations that return side-channel data. +type GenericMQ r m = forall a. Data a => a -> m (r, a) + +------------------------------------------------------------------------------ +-- | Apply the given 'GenericM' at all every node whose children fail the +-- 'GenericQ', but which passes the query itself. +-- +-- The query must be a monotonic function when it returns 'Just'. That is, if +-- @s@ is a subtree of @t@, @q t@ should return @Just True@ if @q s@ does. It +-- is the True-to-false edge of the query that triggers the transformation. +-- +-- Why is the query a @Maybe Bool@? The GHC AST intersperses 'Located' nodes +-- with data nodes, so for any given node we can only definitely return an +-- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is +-- used. +smallestM :: forall m a. Monad m => GenericQ (Maybe (Bool, a)) -> (a -> GenericM m) -> GenericM m +smallestM q f = fmap snd . go + where + go :: GenericMQ Any m + go x = do + case q x of + Nothing -> gmapMQ go x + Just (True, a) -> do + it@(r, x') <- gmapMQ go x + case r of + Any True -> pure it + Any False -> fmap (Any True,) $ f a x' + Just (False, _) -> pure (mempty, x) + +------------------------------------------------------------------------------ +-- | Apply the given 'GenericM' at every node that passes the 'GenericQ', but +-- don't descend into children if the query matches. Because this traversal is +-- root-first, this policy will find the largest subtrees for which the query +-- holds true. +-- +-- Why is the query a @Maybe Bool@? The GHC AST intersperses 'Located' nodes +-- with data nodes, so for any given node we can only definitely return an +-- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is +-- used. +largestM :: forall m a. Monad m => GenericQ (Maybe (Bool, a)) -> (a -> GenericM m) -> GenericM m +largestM q f = go + where + go :: GenericM m + go x = do + case q x of + Just (True, a) -> f a x + Just (False, _) -> pure x + Nothing -> gmapM go x + +newtype MonadicQuery r m a = MonadicQuery + { runMonadicQuery :: m (r, a) + } + deriving stock (Functor) + deriving Applicative via Compose m ((,) r) + + +------------------------------------------------------------------------------ +-- | Like 'gmapM', but also returns side-channel data. +gmapMQ :: + forall f r a. (Monoid r, Data a, Applicative f) => + (forall d. Data d => d -> f (r, d)) -> + a -> + f (r, a) +gmapMQ f = runMonadicQuery . gfoldl k pure + where + k :: Data d => MonadicQuery r f (d -> b) -> d -> MonadicQuery r f b + k c x = c <*> MonadicQuery (f x) diff --git a/src/Text/Fuzzy/Parallel.hs b/src/Text/Fuzzy/Parallel.hs --- a/src/Text/Fuzzy/Parallel.hs +++ b/src/Text/Fuzzy/Parallel.hs @@ -132,7 +132,7 @@ chunkVector :: Int -> Vector a -> [Vector a] chunkVector chunkSize v = do let indices = chunkIndices chunkSize (0,V.length v) - [V.slice l (h-l) v | (l,h) <- indices] + [V.slice l (h-l+1) v | (l,h) <- indices] -- >>> chunkIndices 3 (0,9) -- >>> chunkIndices 3 (0,10) diff --git a/test/data/cabal-exe/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-0.1.0.0/x/a/build/a/autogen/Paths_a.hs b/test/data/cabal-exe/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-0.1.0.0/x/a/build/a/autogen/Paths_a.hs deleted file mode 100644 --- a/test/data/cabal-exe/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-0.1.0.0/x/a/build/a/autogen/Paths_a.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoRebindableSyntax #-} -{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} -module Paths_a ( - version, - getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, - getDataFileName, getSysconfDir - ) where - -import qualified Control.Exception as Exception -import Data.Version (Version(..)) -import System.Environment (getEnv) -import Prelude - -#if defined(VERSION_base) - -#if MIN_VERSION_base(4,0,0) -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#else -catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a -#endif - -#else -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#endif -catchIO = Exception.catch - -version :: Version -version = Version [0,1,0,0] [] -bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath - -bindir = "/Users/pepeiborra/.cabal/bin" -libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3/a-0.1.0.0-inplace-a" -dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3" -datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.3/a-0.1.0.0" -libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.3/a-0.1.0.0" -sysconfdir = "/Users/pepeiborra/.cabal/etc" - -getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath -getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir) -getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir) -getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir) -getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir) -getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir) -getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir) - -getDataFileName :: FilePath -> IO FilePath -getDataFileName name = do - dir <- getDataDir - return (dir ++ "/" ++ name) diff --git a/test/data/import-placement/MultiLinePragma.expected.hs b/test/data/import-placement/MultiLinePragma.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/MultiLinePragma.expected.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards, + OverloadedStrings #-} +{-# OPTIONS_GHC -Wall, + -Wno-unused-imports #-} +import Data.Monoid + + +-- some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/MultiLinePragma.hs b/test/data/import-placement/MultiLinePragma.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/MultiLinePragma.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards, + OverloadedStrings #-} +{-# OPTIONS_GHC -Wall, + -Wno-unused-imports #-} + + +-- some comment +class Semigroup a => SomeData a + +instance SomeData All diff --git a/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs b/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE OverloadedStrings #-} + + +{-# LANGUAGE TupleSections #-} +import Data.Monoid + + + + +class Semigroup a => SomeData a +instance SomeData All + +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/OptionsNotAtTopWithSpaces.hs b/test/data/import-placement/OptionsNotAtTopWithSpaces.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/OptionsNotAtTopWithSpaces.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} + + +{-# LANGUAGE TupleSections #-} + + + + +class Semigroup a => SomeData a +instance SomeData All + +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs b/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs @@ -0,0 +1,8 @@ +import Data.Monoid +class Semigroup a => SomeData a +instance SomeData All + +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/OptionsPragmaNotAtTop.hs b/test/data/import-placement/OptionsPragmaNotAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/OptionsPragmaNotAtTop.hs @@ -0,0 +1,7 @@ +class Semigroup a => SomeData a +instance SomeData All + +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs b/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -Wall, + OPTIONS_GHC -Wno-unrecognised-pragmas #-} +-- another comment +-- oh +{- multi line +comment +-} + +{-# LANGUAGE TupleSections #-} +import Data.Monoid +{- some comment -} + +-- again +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/PragmaNotAtTopMultipleComments.hs b/test/data/import-placement/PragmaNotAtTopMultipleComments.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmaNotAtTopMultipleComments.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -Wall, + OPTIONS_GHC -Wno-unrecognised-pragmas #-} +-- another comment +-- oh +{- multi line +comment +-} + +{-# LANGUAGE TupleSections #-} +{- some comment -} + +-- again +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs b/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -Wall #-} +-- another comment + +{-# LANGUAGE TupleSections #-} +import Data.Monoid +{- some comment -} + + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.hs b/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -Wall #-} +-- another comment + +{-# LANGUAGE TupleSections #-} +{- some comment -} + + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/PragmaNotAtTopWithImports.expected.hs b/test/data/import-placement/PragmaNotAtTopWithImports.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmaNotAtTopWithImports.expected.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TupleSections #-} +module Test +( SomeData(..) +) where +import Data.Text +import Data.Monoid + + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/PragmaNotAtTopWithImports.hs b/test/data/import-placement/PragmaNotAtTopWithImports.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmaNotAtTopWithImports.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TupleSections #-} +module Test +( SomeData(..) +) where +import Data.Text + + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/PragmaNotAtTopWithModuleDecl.expected.hs b/test/data/import-placement/PragmaNotAtTopWithModuleDecl.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmaNotAtTopWithModuleDecl.expected.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} + + +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TupleSections #-} +module Test +( SomeData(..) +) where +import Data.Monoid + + + + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/PragmaNotAtTopWithModuleDecl.hs b/test/data/import-placement/PragmaNotAtTopWithModuleDecl.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/PragmaNotAtTopWithModuleDecl.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} + + +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TupleSections #-} +module Test +( SomeData(..) +) where + + + + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/ShebangNotAtTop.expected.hs b/test/data/import-placement/ShebangNotAtTop.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/ShebangNotAtTop.expected.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} +import Data.Monoid + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +f :: Int -> Int +f x = x * x diff --git a/test/data/import-placement/ShebangNotAtTop.hs b/test/data/import-placement/ShebangNotAtTop.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/ShebangNotAtTop.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE OverloadedStrings #-} + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +f :: Int -> Int +f x = x * x diff --git a/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs b/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs @@ -0,0 +1,8 @@ +import Data.Monoid +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +f :: Int -> Int +f x = x * x diff --git a/test/data/import-placement/ShebangNotAtTopNoSpace.hs b/test/data/import-placement/ShebangNotAtTopNoSpace.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/ShebangNotAtTopNoSpace.hs @@ -0,0 +1,7 @@ +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" + +f :: Int -> Int +f x = x * x diff --git a/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs b/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} + + +{-# OPTIONS_GHC -Wall #-} + + + +{-# LANGUAGE TupleSections #-} +import Data.Monoid + + + + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/ShebangNotAtTopWithSpaces.hs b/test/data/import-placement/ShebangNotAtTopWithSpaces.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/ShebangNotAtTopWithSpaces.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} + + +{-# OPTIONS_GHC -Wall #-} + + + +{-# LANGUAGE TupleSections #-} + + + + +class Semigroup a => SomeData a +instance SomeData All + +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +addOne :: Int -> Int +addOne x = x + 1 diff --git a/test/data/import-placement/WhereDeclLowerInFile.expected.hs b/test/data/import-placement/WhereDeclLowerInFile.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/WhereDeclLowerInFile.expected.hs @@ -0,0 +1,18 @@ +module Asdf + (f + , where') + + where +import Data.Int + + + +f :: Int64 -> Int64 +f = id' + where id' = id + +g :: Int -> Int +g = id + +where' :: Int -> Int +where' = id diff --git a/test/data/import-placement/WhereDeclLowerInFile.hs b/test/data/import-placement/WhereDeclLowerInFile.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/WhereDeclLowerInFile.hs @@ -0,0 +1,17 @@ +module Asdf + (f + , where') + + where + + + +f :: Int64 -> Int64 +f = id' + where id' = id + +g :: Int -> Int +g = id + +where' :: Int -> Int +where' = id diff --git a/test/data/import-placement/WhereKeywordLowerInFileNoExports.expected.hs b/test/data/import-placement/WhereKeywordLowerInFileNoExports.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/WhereKeywordLowerInFileNoExports.expected.hs @@ -0,0 +1,16 @@ +module Asdf + + + where +import Data.Int + + +f :: Int64 -> Int64 +f = id' + where id' = id + +g :: Int -> Int +g = id + +where' :: Int -> Int +where' = id diff --git a/test/data/import-placement/WhereKeywordLowerInFileNoExports.hs b/test/data/import-placement/WhereKeywordLowerInFileNoExports.hs new file mode 100644 --- /dev/null +++ b/test/data/import-placement/WhereKeywordLowerInFileNoExports.hs @@ -0,0 +1,15 @@ +module Asdf + + + where + + +f :: Int64 -> Int64 +f = id' + where id' = id + +g :: Int -> Int +g = id + +where' :: Int -> Int +where' = id diff --git a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.2/a-1.0.0/build/autogen/Paths_a.hs b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.2/a-1.0.0/build/autogen/Paths_a.hs deleted file mode 100644 --- a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.2/a-1.0.0/build/autogen/Paths_a.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoRebindableSyntax #-} -{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} -module Paths_a ( - version, - getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, - getDataFileName, getSysconfDir - ) where - -import qualified Control.Exception as Exception -import Data.Version (Version(..)) -import System.Environment (getEnv) -import Prelude - -#if defined(VERSION_base) - -#if MIN_VERSION_base(4,0,0) -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#else -catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a -#endif - -#else -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#endif -catchIO = Exception.catch - -version :: Version -version = Version [1,0,0] [] -bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath - -bindir = "/Users/pepeiborra/.cabal/bin" -libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.2/a-1.0.0-inplace" -dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.2" -datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.2/a-1.0.0" -libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.2/a-1.0.0" -sysconfdir = "/Users/pepeiborra/.cabal/etc" - -getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath -getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir) -getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir) -getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir) -getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir) -getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir) -getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir) - -getDataFileName :: FilePath -> IO FilePath -getDataFileName name = do - dir <- getDataDir - return (dir ++ "/" ++ name) diff --git a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-1.0.0/build/autogen/Paths_a.hs b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-1.0.0/build/autogen/Paths_a.hs deleted file mode 100644 --- a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-1.0.0/build/autogen/Paths_a.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoRebindableSyntax #-} -{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} -module Paths_a ( - version, - getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, - getDataFileName, getSysconfDir - ) where - -import qualified Control.Exception as Exception -import Data.Version (Version(..)) -import System.Environment (getEnv) -import Prelude - -#if defined(VERSION_base) - -#if MIN_VERSION_base(4,0,0) -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#else -catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a -#endif - -#else -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#endif -catchIO = Exception.catch - -version :: Version -version = Version [1,0,0] [] -bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath - -bindir = "/Users/pepeiborra/.cabal/bin" -libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3/a-1.0.0-inplace" -dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3" -datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.3/a-1.0.0" -libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.3/a-1.0.0" -sysconfdir = "/Users/pepeiborra/.cabal/etc" - -getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath -getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir) -getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir) -getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir) -getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir) -getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir) -getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir) - -getDataFileName :: FilePath -> IO FilePath -getDataFileName name = do - dir <- getDataDir - return (dir ++ "/" ++ name) diff --git a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/b-1.0.0/build/autogen/Paths_b.hs b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/b-1.0.0/build/autogen/Paths_b.hs deleted file mode 100644 --- a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/b-1.0.0/build/autogen/Paths_b.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoRebindableSyntax #-} -{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} -module Paths_b ( - version, - getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, - getDataFileName, getSysconfDir - ) where - -import qualified Control.Exception as Exception -import Data.Version (Version(..)) -import System.Environment (getEnv) -import Prelude - -#if defined(VERSION_base) - -#if MIN_VERSION_base(4,0,0) -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#else -catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a -#endif - -#else -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#endif -catchIO = Exception.catch - -version :: Version -version = Version [1,0,0] [] -bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath - -bindir = "/Users/pepeiborra/.cabal/bin" -libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3/b-1.0.0-inplace" -dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3" -datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.3/b-1.0.0" -libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.3/b-1.0.0" -sysconfdir = "/Users/pepeiborra/.cabal/etc" - -getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath -getBinDir = catchIO (getEnv "b_bindir") (\_ -> return bindir) -getLibDir = catchIO (getEnv "b_libdir") (\_ -> return libdir) -getDynLibDir = catchIO (getEnv "b_dynlibdir") (\_ -> return dynlibdir) -getDataDir = catchIO (getEnv "b_datadir") (\_ -> return datadir) -getLibexecDir = catchIO (getEnv "b_libexecdir") (\_ -> return libexecdir) -getSysconfDir = catchIO (getEnv "b_sysconfdir") (\_ -> return sysconfdir) - -getDataFileName :: FilePath -> IO FilePath -getDataFileName name = do - dir <- getDataDir - return (dir ++ "/" ++ name) diff --git a/test/data/plugin-knownnat/cabal.project b/test/data/plugin-knownnat/cabal.project --- a/test/data/plugin-knownnat/cabal.project +++ b/test/data/plugin-knownnat/cabal.project @@ -1,1 +1,4 @@ packages: . + +-- Needed for ghc >= 9.0.2 and ghc-typelits-natnormalise == 0.7.6 +allow-newer: ghc-typelits-natnormalise:ghc-bignum diff --git a/test/data/symlink/hie.yaml b/test/data/symlink/hie.yaml new file mode 100644 --- /dev/null +++ b/test/data/symlink/hie.yaml @@ -0,0 +1,10 @@ + +cradle: + direct: + arguments: + - -i + - -isrc + - -iother_loc/ + - other_loc/Sym.hs + - src/Foo.hs + - -Wall diff --git a/test/data/symlink/some_loc/Sym.hs b/test/data/symlink/some_loc/Sym.hs new file mode 100644 --- /dev/null +++ b/test/data/symlink/some_loc/Sym.hs @@ -0,0 +1,4 @@ +module Sym where + +foo :: String +foo = "" diff --git a/test/data/symlink/src/Foo.hs b/test/data/symlink/src/Foo.hs new file mode 100644 --- /dev/null +++ b/test/data/symlink/src/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +import Sym + diff --git a/test/exe/HieDbRetry.hs b/test/exe/HieDbRetry.hs new file mode 100644 --- /dev/null +++ b/test/exe/HieDbRetry.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE MultiWayIf #-} +module HieDbRetry (tests) where + +import Control.Concurrent.Extra (Var, modifyVar, newVar, readVar, + withVar) +import Control.Exception (ErrorCall (ErrorCall), evaluate, + throwIO, tryJust) +import Data.Text (Text) +import Data.Tuple.Extra (dupe) +import qualified Database.SQLite.Simple as SQLite +import Development.IDE.Session (retryOnException, + retryOnSqliteBusy) +import Development.IDE.Types.Logger (Logger (Logger), Priority, + noLogging) +import qualified System.Random as Random +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) + +makeLogger :: Var [(Priority, Text)] -> Logger +makeLogger msgsVar = Logger $ \priority msg -> modifyVar msgsVar (\msgs -> pure ((priority, msg) : msgs, ())) + +rng :: Random.StdGen +rng = Random.mkStdGen 0 + +retryOnSqliteBusyForTest :: Logger -> Int -> IO a -> IO a +retryOnSqliteBusyForTest logger maxRetryCount = retryOnException isErrorBusy logger 1 1 maxRetryCount rng + +isErrorBusy :: SQLite.SQLError -> Maybe SQLite.SQLError +isErrorBusy e + | SQLite.SQLError { sqlError = SQLite.ErrorBusy } <- e = Just e + | otherwise = Nothing + +errorBusy :: SQLite.SQLError +errorBusy = SQLite.SQLError{ sqlError = SQLite.ErrorBusy, sqlErrorDetails = "", sqlErrorContext = "" } + +isErrorCall :: ErrorCall -> Maybe ErrorCall +isErrorCall e + | ErrorCall _ <- e = Just e + | otherwise = Nothing + +tests :: TestTree +tests = testGroup "RetryHieDb" + [ testCase "retryOnException throws exception after max retries" $ do + logMsgsVar <- newVar [] + let logger = makeLogger logMsgsVar + let maxRetryCount = 1 + + result <- tryJust isErrorBusy (retryOnSqliteBusyForTest logger maxRetryCount (throwIO errorBusy)) + + case result of + Left exception -> do + exception @?= errorBusy + withVar logMsgsVar $ \logMsgs -> + length logMsgs @?= 2 + -- uncomment if want to compare log msgs + -- logMsgs @?= [] + Right _ -> assertFailure "Expected ErrorBusy exception" + + , testCase "retryOnException doesn't throw if given function doesn't throw" $ do + let expected = 1 :: Int + let maxRetryCount = 0 + + actual <- retryOnSqliteBusyForTest noLogging maxRetryCount (pure expected) + + actual @?= expected + + , testCase "retryOnException retries the number of times it should" $ do + countVar <- newVar 0 + let maxRetryCount = 3 + let incrementThenThrow = modifyVar countVar (\count -> pure (dupe (count + 1))) >> throwIO errorBusy + + _ <- tryJust isErrorBusy (retryOnSqliteBusyForTest noLogging maxRetryCount incrementThenThrow) + + withVar countVar $ \count -> + count @?= maxRetryCount + 1 + + , testCase "retryOnException doesn't retry if exception is not ErrorBusy" $ do + countVar <- newVar (0 :: Int) + let maxRetryCount = 1 + + let throwThenIncrement = do + count <- readVar countVar + if count == 0 then + evaluate (error "dummy exception") + else + modifyVar countVar (\count -> pure (dupe (count + 1))) + + + _ <- tryJust isErrorCall (retryOnSqliteBusyForTest noLogging maxRetryCount throwThenIncrement) + + withVar countVar $ \count -> + count @?= 0 + + , testCase "retryOnSqliteBusy retries on ErrorBusy" $ do + countVar <- newVar (0 :: Int) + + let incrementThenThrowThenIncrement = do + count <- readVar countVar + if count == 0 then + modifyVar countVar (\count -> pure (dupe (count + 1))) >> throwIO errorBusy + else + modifyVar countVar (\count -> pure (dupe (count + 1))) + + _ <- retryOnSqliteBusy noLogging rng incrementThenThrowThenIncrement + + withVar countVar $ \count -> + count @?= 2 + + , testCase "retryOnException exponentially backs off" $ do + logMsgsVar <- newVar ([] :: [(Priority, Text)]) + + let maxDelay = 100 + let baseDelay = 1 + let maxRetryCount = 6 + let logger = makeLogger logMsgsVar + + result <- tryJust isErrorBusy (retryOnException isErrorBusy logger maxDelay baseDelay maxRetryCount rng (throwIO errorBusy)) + + case result of + Left _ -> do + withVar logMsgsVar $ \logMsgs -> + if | ((_, lastLogMsg) : _) <- logMsgs -> + -- uses log messages to indirectly check backoff... + lastLogMsg @?= "Retries exhausted - base delay: 64, maximumDelay: 100, maxRetryCount: 0, exception: SQLite3 returned ErrorBusy while attempting to perform : " + | otherwise -> assertFailure "Expected more than 0 log messages" + Right _ -> assertFailure "Expected ErrorBusy exception" + ] diff --git a/test/exe/Main.hs b/test/exe/Main.hs --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -7,6 +7,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-} @@ -15,7 +16,9 @@ module Main (main) where import Control.Applicative.Combinators -import Control.Exception (bracket_, catch) +import Control.Concurrent +import Control.Exception (bracket_, catch, + finally) import qualified Control.Lens as Lens import Control.Monad import Control.Monad.IO.Class (MonadIO, liftIO) @@ -42,6 +45,7 @@ import Development.IDE.Spans.Common import Development.IDE.Test (Cursor, canonicalizeUri, + configureCheckProject, diagnostic, expectCurrentDiagnostics, expectDiagnostics, @@ -49,15 +53,15 @@ expectMessages, expectNoMoreDiagnostics, flushMessages, - standardizeQuotes, getInterfaceFilesDir, - waitForAction, getStoredKeys, - waitForTypecheck, waitForGC) + standardizeQuotes, + waitForAction, + waitForGC, + waitForTypecheck) import Development.IDE.Test.Runfiles import qualified Development.IDE.Types.Diagnostics as Diagnostics import Development.IDE.Types.Location -import qualified Language.LSP.Types.Lens as Lens (label) import Development.Shake (getDirectoryFilesIO) import qualified Experiments as Bench import Ide.Plugin.Config @@ -68,6 +72,7 @@ SemanticTokensEdit (_start), mkRange) import Language.LSP.Types.Capabilities +import qualified Language.LSP.Types.Lens as Lens (label) import qualified Language.LSP.Types.Lens as Lsp (diagnostics, message, params) @@ -80,16 +85,15 @@ import System.FilePath import System.IO.Extra hiding (withTempDir) import qualified System.IO.Extra -import System.Info.Extra (isWindows) +import System.Info.Extra (isMac, isWindows) import System.Mem (performGC) import System.Process.Extra (CreateProcess (cwd), createPipe, proc, readCreateProcessWithExitCode) import Test.QuickCheck -- import Test.QuickCheck.Instances () -import Control.Concurrent (threadDelay) import Control.Concurrent.Async -import Control.Lens ((^.)) +import Control.Lens (to, (^.)) import Control.Monad.Extra (whenJust) import Data.IORef import Data.IORef.Extra (atomicModifyIORef_) @@ -101,6 +105,7 @@ import Development.IDE.Plugin.Test (TestRequest (BlockSeconds), WaitForIdeRuleResult (..), blockCommandId) +import qualified HieDbRetry import Ide.PluginUtils (pluginDescToIdePlugins) import Ide.Types import qualified Language.LSP.Types as LSP @@ -164,6 +169,7 @@ , pluginParsedResultTests , preprocessorTests , thTests + , symlinkTests , safeTests , unitTests , haddockTests @@ -181,6 +187,7 @@ , codeActionHelperFunctionTests , referenceTests , garbageCollectionTests + , HieDbRetry.tests ] initializeResponseTests :: TestTree @@ -427,10 +434,7 @@ liftIO $ writeFile (path "hie.yaml") cradle _ <- createDoc "ModuleD.hs" "haskell" contentD expectDiagnostics - [ ( "ModuleA.hs" - , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] - ) - , ( "ModuleB.hs" + [ ( "ModuleB.hs" , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] ) ] @@ -589,7 +593,7 @@ ] _ <- createDoc "Foo.hs" "haskell" fooContent if ghcVersion >= GHC90 then - -- Haddock parse errors are ignored on ghc-9.0.1 + -- Haddock parse errors are ignored on ghc-9.0 pure () else expectDiagnostics @@ -780,6 +784,7 @@ , suggestHideShadowTests , suggestImportDisambiguationTests , fixConstructorImportTests + , fixModuleImportTypoTests , importRenameActionTests , fillTypedHoleTests , addSigActionTests @@ -857,28 +862,203 @@ insertImportTests :: TestTree insertImportTests = testGroup "insert import" - [ checkImport "above comment at top of module" "CommentAtTop.hs" "CommentAtTop.expected.hs" "import Data.Monoid" - , checkImport "above multiple comments below" "CommentAtTopMultipleComments.hs" "CommentAtTopMultipleComments.expected.hs" "import Data.Monoid" - , checkImport "above curly brace comment" "CommentCurlyBraceAtTop.hs" "CommentCurlyBraceAtTop.expected.hs" "import Data.Monoid" - , checkImport "above multi-line comment" "MultiLineCommentAtTop.hs" "MultiLineCommentAtTop.expected.hs" "import Data.Monoid" - , checkImport "above comment with no module explicit exports" "NoExplicitExportCommentAtTop.hs" "NoExplicitExportCommentAtTop.expected.hs" "import Data.Monoid" - , checkImport "above two-dash comment with no pipe" "TwoDashOnlyComment.hs" "TwoDashOnlyComment.expected.hs" "import Data.Monoid" - , checkImport "above comment with no (module .. where) decl" "NoModuleDeclarationCommentAtTop.hs" "NoModuleDeclarationCommentAtTop.expected.hs" "import Data.Monoid" - , checkImport "comment not at top with no (module .. where) decl" "NoModuleDeclaration.hs" "NoModuleDeclaration.expected.hs" "import Data.Monoid" - , checkImport "comment not at top (data dec is)" "DataAtTop.hs" "DataAtTop.expected.hs" "import Data.Monoid" - , checkImport "comment not at top (newtype is)" "NewTypeAtTop.hs" "NewTypeAtTop.expected.hs" "import Data.Monoid" - , checkImport "with no explicit module exports" "NoExplicitExports.hs" "NoExplicitExports.expected.hs" "import Data.Monoid" - , checkImport "add to correctly placed exisiting import" "ImportAtTop.hs" "ImportAtTop.expected.hs" "import Data.Monoid" - , checkImport "add to multiple correctly placed exisiting imports" "MultipleImportsAtTop.hs" "MultipleImportsAtTop.expected.hs" "import Data.Monoid" - , checkImport "with language pragma at top of module" "LangPragmaModuleAtTop.hs" "LangPragmaModuleAtTop.expected.hs" "import Data.Monoid" - , checkImport "with language pragma and explicit module exports" "LangPragmaModuleWithComment.hs" "LangPragmaModuleWithComment.expected.hs" "import Data.Monoid" - , checkImport "with language pragma at top and no module declaration" "LanguagePragmaAtTop.hs" "LanguagePragmaAtTop.expected.hs" "import Data.Monoid" - , checkImport "with multiple lang pragmas and no module declaration" "MultipleLanguagePragmasNoModuleDeclaration.hs" "MultipleLanguagePragmasNoModuleDeclaration.expected.hs" "import Data.Monoid" - , checkImport "with pragmas and shebangs" "LanguagePragmasThenShebangs.hs" "LanguagePragmasThenShebangs.expected.hs" "import Data.Monoid" - , checkImport "with pragmas and shebangs but no comment at top" "PragmasAndShebangsNoComment.hs" "PragmasAndShebangsNoComment.expected.hs" "import Data.Monoid" - , checkImport "module decl no exports under pragmas and shebangs" "PragmasShebangsAndModuleDecl.hs" "PragmasShebangsAndModuleDecl.expected.hs" "import Data.Monoid" - , checkImport "module decl with explicit import under pragmas and shebangs" "PragmasShebangsModuleExplicitExports.hs" "PragmasShebangsModuleExplicitExports.expected.hs" "import Data.Monoid" - , checkImport "module decl and multiple imports" "ModuleDeclAndImports.hs" "ModuleDeclAndImports.expected.hs" "import Data.Monoid" + [ expectFailBecause + ("'findPositionFromImportsOrModuleDecl' function adds import directly under line with module declaration, " + ++ "not accounting for case when 'where' keyword is placed on lower line") + (checkImport + "module where keyword lower in file no exports" + "WhereKeywordLowerInFileNoExports.hs" + "WhereKeywordLowerInFileNoExports.expected.hs" + "import Data.Int") + , expectFailBecause + ("'findPositionFromImportsOrModuleDecl' function adds import directly under line with module exports list, " + ++ "not accounting for case when 'where' keyword is placed on lower line") + (checkImport + "module where keyword lower in file with exports" + "WhereDeclLowerInFile.hs" + "WhereDeclLowerInFile.expected.hs" + "import Data.Int") + , expectFailBecause + "'findNextPragmaPosition' function doesn't account for case when shebang is not placed at top of file" + (checkImport + "Shebang not at top with spaces" + "ShebangNotAtTopWithSpaces.hs" + "ShebangNotAtTopWithSpaces.expected.hs" + "import Data.Monoid") + , expectFailBecause + "'findNextPragmaPosition' function doesn't account for case when shebang is not placed at top of file" + (checkImport + "Shebang not at top no space" + "ShebangNotAtTopNoSpace.hs" + "ShebangNotAtTopNoSpace.expected.hs" + "import Data.Monoid") + , expectFailBecause + ("'findNextPragmaPosition' function doesn't account for case " + ++ "when OPTIONS_GHC pragma is not placed at top of file") + (checkImport + "OPTIONS_GHC pragma not at top with spaces" + "OptionsNotAtTopWithSpaces.hs" + "OptionsNotAtTopWithSpaces.expected.hs" + "import Data.Monoid") + , expectFailBecause + ("'findNextPragmaPosition' function doesn't account for " + ++ "case when shebang is not placed at top of file") + (checkImport + "Shebang not at top of file" + "ShebangNotAtTop.hs" + "ShebangNotAtTop.expected.hs" + "import Data.Monoid") + , expectFailBecause + ("'findNextPragmaPosition' function doesn't account for case " + ++ "when OPTIONS_GHC is not placed at top of file") + (checkImport + "OPTIONS_GHC pragma not at top of file" + "OptionsPragmaNotAtTop.hs" + "OptionsPragmaNotAtTop.expected.hs" + "import Data.Monoid") + , expectFailBecause + ("'findNextPragmaPosition' function doesn't account for case when " + ++ "OPTIONS_GHC pragma is not placed at top of file") + (checkImport + "pragma not at top with comment at top" + "PragmaNotAtTopWithCommentsAtTop.hs" + "PragmaNotAtTopWithCommentsAtTop.expected.hs" + "import Data.Monoid") + , expectFailBecause + ("'findNextPragmaPosition' function doesn't account for case when " + ++ "OPTIONS_GHC pragma is not placed at top of file") + (checkImport + "pragma not at top multiple comments" + "PragmaNotAtTopMultipleComments.hs" + "PragmaNotAtTopMultipleComments.expected.hs" + "import Data.Monoid") + , expectFailBecause + "'findNextPragmaPosition' function doesn't account for case of multiline pragmas" + (checkImport + "after multiline language pragmas" + "MultiLinePragma.hs" + "MultiLinePragma.expected.hs" + "import Data.Monoid") + , checkImport + "pragmas not at top with module declaration" + "PragmaNotAtTopWithModuleDecl.hs" + "PragmaNotAtTopWithModuleDecl.expected.hs" + "import Data.Monoid" + , checkImport + "pragmas not at top with imports" + "PragmaNotAtTopWithImports.hs" + "PragmaNotAtTopWithImports.expected.hs" + "import Data.Monoid" + , checkImport + "above comment at top of module" + "CommentAtTop.hs" + "CommentAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "above multiple comments below" + "CommentAtTopMultipleComments.hs" + "CommentAtTopMultipleComments.expected.hs" + "import Data.Monoid" + , checkImport + "above curly brace comment" + "CommentCurlyBraceAtTop.hs" + "CommentCurlyBraceAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "above multi-line comment" + "MultiLineCommentAtTop.hs" + "MultiLineCommentAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "above comment with no module explicit exports" + "NoExplicitExportCommentAtTop.hs" + "NoExplicitExportCommentAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "above two-dash comment with no pipe" + "TwoDashOnlyComment.hs" + "TwoDashOnlyComment.expected.hs" + "import Data.Monoid" + , checkImport + "above comment with no (module .. where) decl" + "NoModuleDeclarationCommentAtTop.hs" + "NoModuleDeclarationCommentAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "comment not at top with no (module .. where) decl" + "NoModuleDeclaration.hs" + "NoModuleDeclaration.expected.hs" + "import Data.Monoid" + , checkImport + "comment not at top (data dec is)" + "DataAtTop.hs" + "DataAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "comment not at top (newtype is)" + "NewTypeAtTop.hs" + "NewTypeAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "with no explicit module exports" + "NoExplicitExports.hs" + "NoExplicitExports.expected.hs" + "import Data.Monoid" + , checkImport + "add to correctly placed exisiting import" + "ImportAtTop.hs" + "ImportAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "add to multiple correctly placed exisiting imports" + "MultipleImportsAtTop.hs" + "MultipleImportsAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "with language pragma at top of module" + "LangPragmaModuleAtTop.hs" + "LangPragmaModuleAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "with language pragma and explicit module exports" + "LangPragmaModuleWithComment.hs" + "LangPragmaModuleWithComment.expected.hs" + "import Data.Monoid" + , checkImport + "with language pragma at top and no module declaration" + "LanguagePragmaAtTop.hs" + "LanguagePragmaAtTop.expected.hs" + "import Data.Monoid" + , checkImport + "with multiple lang pragmas and no module declaration" + "MultipleLanguagePragmasNoModuleDeclaration.hs" + "MultipleLanguagePragmasNoModuleDeclaration.expected.hs" + "import Data.Monoid" + , checkImport + "with pragmas and shebangs" + "LanguagePragmasThenShebangs.hs" + "LanguagePragmasThenShebangs.expected.hs" + "import Data.Monoid" + , checkImport + "with pragmas and shebangs but no comment at top" + "PragmasAndShebangsNoComment.hs" + "PragmasAndShebangsNoComment.expected.hs" + "import Data.Monoid" + , checkImport + "module decl no exports under pragmas and shebangs" + "PragmasShebangsAndModuleDecl.hs" + "PragmasShebangsAndModuleDecl.expected.hs" + "import Data.Monoid" + , checkImport + "module decl with explicit import under pragmas and shebangs" + "PragmasShebangsModuleExplicitExports.hs" + "PragmasShebangsModuleExplicitExports.expected.hs" + "import Data.Monoid" + , checkImport + "module decl and multiple imports" + "ModuleDeclAndImports.hs" + "ModuleDeclAndImports.expected.hs" + "import Data.Monoid" ] checkImport :: String -> FilePath -> FilePath -> T.Text -> TestTree @@ -1103,19 +1283,20 @@ , "stuffB :: Integer" , "stuffB = 123" , "stuffC = ()" + , "_stuffD = '_'" ] _docA <- createDoc "ModuleA.hs" "haskell" contentA let contentB = T.unlines [ "{-# OPTIONS_GHC -Wunused-imports #-}" , "module ModuleB where" - , "import ModuleA (stuffA, stuffB, stuffC, stuffA)" + , "import ModuleA (stuffA, stuffB, _stuffD, stuffC, stuffA)" , "main = print stuffB" ] docB <- createDoc "ModuleB.hs" "haskell" contentB _ <- waitForDiagnostics [InR action@CodeAction { _title = actionTitle }, _] <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove stuffA, stuffC from import" @=? actionTitle + liftIO $ "Remove _stuffD, stuffA, stuffC from import" @=? actionTitle executeCodeAction action contentAfterAction <- documentContents docB let expectedContentAfterAction = T.unlines @@ -1560,7 +1741,8 @@ , "import A (pattern Some)" , "k (Some x) = x" ]) - , testSession "type constructor name same as data constructor name" $ template + , ignoreForGHC92 "Diagnostic message has no suggestions" $ + testSession "type constructor name same as data constructor name" $ template [("ModuleA.hs", T.unlines [ "module ModuleA where" , "newtype Foo = Foo Int" @@ -1603,10 +1785,7 @@ codeActionTitle CodeAction{_title=x} = x template setUpModules moduleUnderTest range expectedTitles expectedContentB = do - sendNotification SWorkspaceDidChangeConfiguration - (DidChangeConfigurationParams $ toJSON - def{checkProject = overrideCheckProject}) - + configureCheckProject overrideCheckProject mapM_ (\x -> createDoc (fst x) "haskell" (snd x)) setUpModules docB <- createDoc (fst moduleUnderTest) "haskell" (snd moduleUnderTest) @@ -1633,6 +1812,31 @@ contentAfterAction <- documentContents docB liftIO $ expectedContentB @=? contentAfterAction +fixModuleImportTypoTests :: TestTree +fixModuleImportTypoTests = testGroup "fix module import typo" + [ testSession "works when single module suggested" $ do + doc <- createDoc "A.hs" "haskell" "import Data.Cha" + _ <- waitForDiagnostics + InR action@CodeAction { _title = actionTitle } : _ <- getCodeActions doc (R 0 0 0 10) + liftIO $ actionTitle @?= "replace with Data.Char" + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ contentAfterAction @?= "import Data.Char" + , testSession "works when multiple modules suggested" $ do + doc <- createDoc "A.hs" "haskell" "import Data.I" + _ <- waitForDiagnostics + actions <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> getCodeActions doc (R 0 0 0 10) + let actionTitles = [ title | InR CodeAction{_title=title} <- actions ] + liftIO $ actionTitles @?= [ "replace with Data.Eq" + , "replace with Data.Int" + , "replace with Data.Ix" + ] + let InR replaceWithDataEq : _ = actions + executeCodeAction replaceWithDataEq + contentAfterAction <- documentContents doc + liftIO $ contentAfterAction @?= "import Data.Eq" + ] + extendImportTestsRegEx :: TestTree extendImportTestsRegEx = testGroup "regex parsing" [ @@ -1783,6 +1987,7 @@ test = test' False wantWait = test' True True test' waitForCheckProject wanted imps def other newImp = testSessionWithExtraFiles "hover" (T.unpack def) $ \dir -> do + configureCheckProject waitForCheckProject let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo, B]}}" @@ -1793,8 +1998,8 @@ _diags <- waitForDiagnostics -- there isn't a good way to wait until the whole project is checked atm when waitForCheckProject $ liftIO $ sleep 0.5 - let defLine = length imps + 1 - range = Range (Position defLine 0) (Position defLine maxBoundUinteger) + let defLine = fromIntegral $ length imps + 1 + range = Range (Position defLine 0) (Position defLine maxBound) actions <- getCodeActions doc range if wanted then do @@ -2107,7 +2312,7 @@ doc <- createDoc "A.hs" "haskell" $ T.unlines (header <> origin) void waitForDiagnostics waitForProgressDone - cas <- getCodeActions doc (Range (Position (line1 + length header) col1) (Position (line2 + length header) col2)) + cas <- getCodeActions doc (Range (Position (fromIntegral $ line1 + length header) col1) (Position (fromIntegral $ line2 + length header) col2)) void $ k [x | x@(InR ca) <- cas, "Hide" `T.isPrefixOf` (ca ^. L.title)] contentAfter <- documentContents doc liftIO $ contentAfter @?= T.unlines (header <> expected) @@ -2326,9 +2531,9 @@ return (action, actionTitle) addTypeAnnotationsToLiteralsTest :: TestTree -addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals to satisfy contraints" +addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals to satisfy constraints" [ - testSession "add default type to satisfy one contraint" $ + testSession "add default type to satisfy one constraint" $ testFor (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "module A (f) where" @@ -2343,7 +2548,7 @@ , "f = (1 :: Integer)" ]) - , testSession "add default type to satisfy one contraint in nested expressions" $ + , testSession "add default type to satisfy one constraint in nested expressions" $ testFor (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "module A where" @@ -2361,7 +2566,7 @@ , " let x = (3 :: Integer)" , " in x" ]) - , testSession "add default type to satisfy one contraint in more nested expressions" $ + , testSession "add default type to satisfy one constraint in more nested expressions" $ testFor (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "module A where" @@ -2379,7 +2584,7 @@ , " let x = let y = (5 :: Integer) in y" , " in x" ]) - , testSession "add default type to satisfy one contraint with duplicate literals" $ + , testSession "add default type to satisfy one constraint with duplicate literals" $ testFor (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}" @@ -2401,7 +2606,8 @@ , "" , "f = seq (\"debug\" :: " <> listOfChar <> ") traceShow \"debug\"" ]) - , testSession "add default type to satisfy two contraints" $ + , knownBrokenForGhcVersions [GHC92] "GHC 9.2 only has 'traceShow' in error span" $ + testSession "add default type to satisfy two constraints" $ testFor (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}" @@ -2421,7 +2627,8 @@ , "" , "f a = traceShow (\"debug\" :: " <> listOfChar <> ") a" ]) - , testSession "add default type to satisfy two contraints with duplicate literals" $ + , knownBrokenForGhcVersions [GHC92] "GHC 9.2 only has 'traceShow' in error span" $ + testSession "add default type to satisfy two constraints with duplicate literals" $ testFor (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}" @@ -2542,7 +2749,7 @@ let expectedCode = sourceCode newA newB newC doc <- createDoc "Testing.hs" "haskell" originalCode _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBoundUinteger)) + actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound)) chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands executeCodeAction chosenAction modifiedCode <- documentContents doc @@ -2583,7 +2790,7 @@ , "ioToSome = " <> x ] doc <- createDoc "Test.hs" "haskell" $ mkDoc "_toException" _ <- waitForDiagnostics - actions <- getCodeActions doc (Range (Position 3 0) (Position 3 maxBoundUinteger)) + actions <- getCodeActions doc (Range (Position 3 0) (Position 3 maxBound)) chosen <- liftIO $ pickActionWithTitle "replace _toException with E.toException" actions executeCodeAction chosen modifiedCode <- documentContents doc @@ -3078,7 +3285,7 @@ let expectedCode = after' def sig doc <- createDoc "Sigs.hs" "haskell" originalCode _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 5 1) (Position 5 maxBoundUinteger)) + actionsOrCommands <- getCodeActions doc (Range (Position 5 1) (Position 5 maxBound)) chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands executeCodeAction chosenAction modifiedCode <- documentContents doc @@ -3100,7 +3307,7 @@ , "pattern Point{x, y} <- (x, y)\n where Point x y = (x, y)" >:: "pattern Point :: a -> b -> (a, b)" , "pattern MkT1' b = MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a" , "pattern MkT1' b <- MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a" - , "pattern MkT1' b <- MkT1 42 b\n where MkT1' b = T1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a" + , "pattern MkT1' b <- MkT1 42 b\n where MkT1' b = MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a" ] exportUnusedTests :: TestTree @@ -3126,7 +3333,8 @@ (R 2 0 2 11) "Export ‘bar’" Nothing - , testSession "type is exported but not the constructor of same name" $ template + , ignoreForGHC92 "Diagnostic message has no suggestions" $ + testSession "type is exported but not the constructor of same name" $ template (T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" , "module A (Foo) where" @@ -3167,7 +3375,7 @@ "Export ‘bar’" (Just $ T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" - , "module A (foo,bar) where" + , "module A (foo, bar) where" , "foo = id" , "bar = foo"]) , testSession "multi line explicit exports" $ template @@ -3184,7 +3392,7 @@ [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" , "module A" , " (" - , " foo,bar) where" + , " foo, bar) where" , "foo = id" , "bar = foo"]) , testSession "export list ends in comma" $ template @@ -3261,7 +3469,7 @@ (Just $ T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" , "{-# LANGUAGE TypeFamilies #-}" - , "module A (Foo(..)) where" + , "module A (Foo) where" , "type family Foo p"]) , testSession "unused typeclass" $ template (T.unlines @@ -3322,7 +3530,7 @@ [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" , "{-# LANGUAGE TypeFamilies #-}" , "{-# LANGUAGE TypeOperators #-}" - , "module A (type (:<)(..)) where" + , "module A (type (:<)) where" , "type family (:<)"]) , testSession "typeclass operator" $ template (T.unlines @@ -3618,13 +3826,13 @@ , ("pattern Point{x, y} <- (x, y)\n where Point x y = (x, y)", "pattern Point :: a -> b -> (a, b)") , ("pattern MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") , ("pattern MkT1' b <- MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") - , ("pattern MkT1' b <- MkT1 42 b\n where MkT1' b = T1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") + , ("pattern MkT1' b <- MkT1 42 b\n where MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") , ("qualifiedSigTest= C.realPart", "qualifiedSigTest :: C.Complex a -> a") , ("head = 233", "head :: Integer") , ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, " <> listOfChar <> ")") , ("symbolKindTest = Proxy @\"qwq\"", "symbolKindTest :: Proxy \"qwq\"") , ("promotedKindTest = Proxy @Nothing", "promotedKindTest :: Proxy 'Nothing") - , ("typeOperatorTest = Refl", "typeOperatorTest :: a :~: a") + , ("typeOperatorTest = Refl", if ghcVersion >= GHC92 then "typeOperatorTest :: forall {k} {a :: k}. a :~: a" else "typeOperatorTest :: a :~: a") , ("notInScopeTest = mkCharType", "notInScopeTest :: String -> Data.Data.DataType") ] in testGroup @@ -3776,14 +3984,14 @@ spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]] docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]] ; constr = [ExpectHoverText ["Monad m"]] - eitL40 = Position 44 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]] - intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: *\n"]] + eitL40 = Position 44 28 ; kindE = [ExpectHoverText [if ghcVersion >= GHC92 then ":: Type -> Type -> Type\n" else ":: * -> * -> *\n"]] + intL40 = Position 44 34 ; kindI = [ExpectHoverText [if ghcVersion >= GHC92 then ":: Type\n" else ":: *\n"]] tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]] intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]] chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]] txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]] lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]] - outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5] + outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 50 0 50 5] innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7] holeL60 = Position 62 7 ; hleInfo = [ExpectHoverText ["_ ::"]] cccL17 = Position 17 16 ; docLink = [ExpectHoverText ["[Documentation](file:///"]] @@ -3837,15 +4045,19 @@ test no yes docL41 constr "type constraint in hover info #1012" else test no broken docL41 constr "type constraint in hover info #1012" - , test broken broken outL45 outSig "top-level signature #767" + , test no yes outL45 outSig "top-level signature #767" , test broken broken innL48 innSig "inner signature #767" , test no yes holeL60 hleInfo "hole without internal name #831" , test no skip cccL17 docLink "Haddock html links" , testM yes yes imported importedSig "Imported symbol" , testM yes yes reexported reexportedSig "Imported symbol (reexported)" - , if ghcVersion == GHC90 && isWindows then + , if | ghcVersion == GHC90 && isWindows -> test no broken thLocL57 thLoc "TH Splice Hover" - else + | ghcVersion == GHC92 && (isWindows || isMac) -> + -- Some GHC 9.2 distributions ship without .hi docs + -- https://gitlab.haskell.org/ghc/ghc/-/issues/20903 + test no broken thLocL57 thLoc "TH Splice Hover" + | otherwise -> test no yes thLocL57 thLoc "TH Splice Hover" ] where yes, broken :: (TestTree -> Maybe TestTree) @@ -3863,6 +4075,7 @@ pluginSimpleTests :: TestTree pluginSimpleTests = ignoreInWindowsForGHC88And810 $ + ignoreForGHC92 "blocked on ghc-typelits-natnormalise" $ testSessionWithExtraFiles "plugin-knownnat" "simple plugin" $ \dir -> do _ <- openDoc (dir "KnownNat.hs") "haskell" liftIO $ writeFile (dir"hie.yaml") @@ -3877,6 +4090,7 @@ pluginParsedResultTests :: TestTree pluginParsedResultTests = ignoreInWindowsForGHC88And810 $ + ignoreForGHC92 "No need for this plugin anymore!" $ testSessionWithExtraFiles "plugin-recorddot" "parsedResultAction plugin" $ \dir -> do _ <- openDoc (dir "RecordDot.hs") "haskell" expectNoMoreDiagnostics 2 @@ -3893,9 +4107,9 @@ "foo = 42" ] -- The error locations differ depending on which C-preprocessor is used. - -- Some give the column number and others don't (hence -1). Assert either + -- Some give the column number and others don't (hence maxBound == -1 unsigned). Assert either -- of them. - (run $ expectError content (2, -1)) + (run $ expectError content (2, maxBound)) `catch` ( \e -> do let _ = e :: HUnitFailure run $ expectError content (2, 1) @@ -4056,6 +4270,18 @@ expectDiagnostics [ ( cPath, [(DsWarning, (3, 0), "Top-level binding with no type signature: a :: A")] ) ] ] +-- | Tests for projects that use symbolic links one way or another +symlinkTests :: TestTree +symlinkTests = + testGroup "Projects using Symlinks" + [ testCase "Module is symlinked" $ runWithExtraFiles "symlink" $ \dir -> do + liftIO $ createFileLink (dir "some_loc" "Sym.hs") (dir "other_loc" "Sym.hs") + let fooPath = dir "src" "Foo.hs" + _ <- openDoc fooPath "haskell" + expectDiagnosticsWithTags [("src" "Foo.hs", [(DsWarning, (2, 0), "The import of 'Sym' is redundant", Just DtUnnecessary)])] + pure () + ] + -- | Test that all modules have linkables thLoadingTest :: TestTree thLoadingTest = testCase "Loading linkables" $ runWithExtraFiles "THLoading" $ \dir -> do @@ -4063,7 +4289,6 @@ _ <- openDoc thb "haskell" expectNoMoreDiagnostics 1 - -- | test that TH is reevaluated on typecheck thReloadingTest :: Bool -> TestTree thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do @@ -4317,6 +4542,15 @@ ,("abcdefghi", CiFunction, "abcdefghi", True, False, Nothing) ], completionTest + "type family" + ["{-# LANGUAGE DataKinds, TypeFamilies #-}" + ,"type family Bar a" + ,"a :: Ba" + ] + (Position 2 7) + [("Bar", CiStruct, "Bar", True, False, Nothing) + ], + completionTest "class method" [ "class Test a where" @@ -4771,7 +5005,7 @@ , DocumentHighlight (R 6 10 6 13) (Just HkRead) , DocumentHighlight (R 7 12 7 15) (Just HkRead) ] - , knownBrokenForGhcVersions [GHC90] "Ghc9 highlights the constructor and not just this field" $ + , knownBrokenForGhcVersions [GHC90, GHC92] "Ghc9 highlights the constructor and not just this field" $ testSessionWait "record" $ do doc <- createDoc "A.hs" "haskell" recsource _ <- waitForDiagnostics @@ -4912,7 +5146,7 @@ let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"] docId <- createDoc "A.hs" "haskell" source symbols <- getDocumentSymbols docId - liftIO $ symbols @=? Left + liftIO $ symbols @?= Left [ docSymbolWithChildren "A" SkStruct (R 0 0 2 13) [ docSymbolWithChildren' "B" SkConstructor (R 0 9 2 13) (R 0 9 0 10) [ docSymbol "x" SkField (R 1 2 1 3) @@ -4976,7 +5210,7 @@ SkFile Nothing Nothing - (R 0 0 maxBoundUinteger 0) + (R 0 0 maxBound 0) loc (Just $ List cc) classSymbol name loc cc = DocumentSymbol name @@ -4988,7 +5222,7 @@ loc (Just $ List cc) -pattern R :: Int -> Int -> Int -> Int -> Range +pattern R :: UInt -> UInt -> UInt -> UInt -> Range pattern R x y x' y' = Range (Position x y) (Position x' y') xfail :: TestTree -> String -> TestTree @@ -5005,6 +5239,11 @@ ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8 and 8.10" | otherwise = id +ignoreForGHC92 :: String -> TestTree -> TestTree +ignoreForGHC92 msg + | ghcVersion == GHC92 = ignoreTestBecause msg + | otherwise = id + ignoreInWindowsForGHC88 :: TestTree -> TestTree ignoreInWindowsForGHC88 | ghcVersion == GHC88 = @@ -5029,10 +5268,10 @@ -- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples deriving Eq -mkR :: Int -> Int -> Int -> Int -> Expect +mkR :: UInt -> UInt -> UInt -> UInt -> Expect mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn -mkL :: Uri -> Int -> Int -> Int -> Int -> Expect +mkL :: Uri -> UInt -> UInt -> UInt -> UInt -> Expect mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn haddockTests :: TestTree @@ -5168,7 +5407,7 @@ expectDiagnostics $ if ghcVersion >= GHC90 -- String vs [Char] causes this change in error message - then [("Foo.hs", [(DsError, (4, 6), "Couldn't match type")])] + then [("Foo.hs", [(DsError, if ghcVersion >= GHC92 then (4,11) else (4, 6), "Couldn't match type")])] else [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])] -- Now modify the dependent file liftIO $ writeFile depFilePath "B" @@ -5325,6 +5564,7 @@ ifaceErrorTest :: TestTree ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \dir -> do + configureCheckProject True let bPath = dir "B.hs" pPath = dir "P.hs" @@ -5689,6 +5929,8 @@ referenceTestSession :: String -> FilePath -> [FilePath] -> (FilePath -> Session ()) -> TestTree referenceTestSession name thisDoc docs' f = testSessionWithExtraFiles "references" name $ \dir -> do + -- needed to build whole project indexing + configureCheckProject True let docs = map (dir ) $ delete thisDoc $ nubOrd docs' -- Initial Index docid <- openDoc thisDoc "haskell" @@ -5716,14 +5958,14 @@ where docs = map fst3 expected -type SymbolLocation = (FilePath, Int, Int) +type SymbolLocation = (FilePath, UInt, UInt) expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion expectSameLocations actual expected = do let actual' = Set.map (\location -> (location ^. L.uri - , location ^. L.range . L.start . L.line - , location ^. L.range . L.start . L.character)) + , location ^. L.range . L.start . L.line . to fromIntegral + , location ^. L.range . L.start . L.character . to fromIntegral)) $ Set.fromList actual expected' <- Set.fromList <$> (forM expected $ \(file, l, c) -> do @@ -5769,7 +6011,7 @@ , title == actionTitle ] -mkRange :: Int -> Int -> Int -> Int -> Range +mkRange :: UInt -> UInt -> UInt -> UInt -> Range mkRange a b c d = Range (Position a b) (Position c d) run :: Session a -> IO a @@ -5819,7 +6061,9 @@ -- Only sets HOME if it wasn't already set. setEnv "HOME" "/homeless-shelter" False conf <- getConfigFromEnv - runSessionWithConfig conf cmd lspTestCaps projDir s + runSessionWithConfig conf cmd lspTestCaps projDir $ do + configureCheckProject False + s getConfigFromEnv :: IO SessionConfig getConfigFromEnv = do @@ -5836,7 +6080,7 @@ convertVal _ = True lspTestCaps :: ClientCapabilities -lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True } +lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } openTestDataDoc :: FilePath -> Session TextDocumentIdentifier openTestDataDoc path = do @@ -6013,9 +6257,13 @@ if t /= t' then return delay_us else findResolution_us (delay_us * 10) -testIde :: IDE.Arguments -> Session () -> IO () -testIde arguments session = do +testIde :: IDE.Arguments -> Session a -> IO a +testIde = testIde' "." + +testIde' :: FilePath -> IDE.Arguments -> Session a -> IO a +testIde' projDir arguments session = do config <- getConfigFromEnv + cwd <- getCurrentDirectory (hInRead, hInWrite) <- createPipe (hOutRead, hOutWrite) <- createPipe let server = IDE.defaultMain arguments @@ -6023,9 +6271,11 @@ , IDE.argsHandleOut = pure hOutWrite } - withAsync server $ \_ -> - runSessionWithHandles hInWrite hOutRead config lspTestCaps "." session + flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ -> + runSessionWithHandles hInWrite hOutRead config lspTestCaps projDir session + + positionMappingTests :: TestTree positionMappingTests = testGroup "position mapping" @@ -6168,25 +6418,29 @@ genPosition :: Rope -> Gen Position genPosition r = do - row <- choose (0, max 0 $ rows - 1) + let rows = Rope.rows r + row <- choose (0, max 0 $ rows - 1) `suchThat` inBounds @UInt let columns = Rope.columns (nthLine row r) - column <- choose (0, max 0 $ columns - 1) - pure $ Position row column - where rows = Rope.rows r + column <- choose (0, max 0 $ columns - 1) `suchThat` inBounds @UInt + pure $ Position (fromIntegral row) (fromIntegral column) genRange :: Rope -> Gen Range genRange r = do + let rows = Rope.rows r startPos@(Position startLine startColumn) <- genPosition r - let maxLineDiff = max 0 $ rows - 1 - startLine - endLine <- choose (startLine, startLine + maxLineDiff) - let columns = Rope.columns (nthLine endLine r) + let maxLineDiff = max 0 $ rows - 1 - fromIntegral startLine + endLine <- choose (fromIntegral startLine, fromIntegral startLine + maxLineDiff) `suchThat` inBounds @UInt + let columns = Rope.columns (nthLine (fromIntegral endLine) r) endColumn <- - if startLine == endLine - then choose (startColumn, columns) + if fromIntegral startLine == endLine + then choose (fromIntegral startColumn, columns) else choose (0, max 0 $ columns - 1) - pure $ Range startPos (Position endLine endColumn) - where rows = Rope.rows r + `suchThat` inBounds @UInt + pure $ Range startPos (Position (fromIntegral endLine) (fromIntegral endColumn)) +inBounds :: forall b a . (Integral a, Integral b, Bounded b) => a -> Bool +inBounds a = let i = toInteger a in i <= toInteger (maxBound @b) && i >= toInteger (minBound @b) + -- | Get the ith line of a rope, starting from 0. Trailing newline not included. nthLine :: Int -> Rope -> Rope nthLine i r @@ -6224,11 +6478,6 @@ | otherwise = "[Char]" -- | Ghc 9 doesn't include the $-sign in TH warnings like earlier versions did -thDollarIdx :: Int +thDollarIdx :: UInt thDollarIdx | ghcVersion >= GHC90 = 1 | otherwise = 0 - --- | We don't have a uinteger type yet. So hardcode the maxBound of uinteger, 2 ^ 31 - 1 --- as a constant. -maxBoundUinteger :: Int -maxBoundUinteger = 2147483647 diff --git a/test/exe/Progress.hs b/test/exe/Progress.hs --- a/test/exe/Progress.hs +++ b/test/exe/Progress.hs @@ -1,7 +1,13 @@ +{-# LANGUAGE PackageImports #-} module Progress (tests) where +import Control.Concurrent.STM +import Data.Foldable (for_) import qualified Data.HashMap.Strict as Map +import Development.IDE (NormalizedFilePath) import Development.IDE.Core.ProgressReporting +import qualified "list-t" ListT +import qualified StmContainers.Map as STM import Test.Tasty import Test.Tasty.HUnit @@ -10,6 +16,11 @@ [ reportProgressTests ] +data InProgressModel = InProgressModel { + done, todo :: Int, + current :: Map.HashMap NormalizedFilePath Int +} + reportProgressTests :: TestTree reportProgressTests = testGroup "recordProgress" [ test "addNew" addNew @@ -18,11 +29,32 @@ , test "done" done ] where - p0 = InProgress 0 0 mempty - addNew = recordProgress "A" succ p0 - increase = recordProgress "A" succ addNew - decrease = recordProgress "A" succ increase - done = recordProgress "A" pred decrease - model InProgress{..} = + p0 = pure $ InProgressModel 0 0 mempty + addNew = recordProgressModel "A" succ p0 + increase = recordProgressModel "A" succ addNew + decrease = recordProgressModel "A" succ increase + done = recordProgressModel "A" pred decrease + recordProgressModel key change state = + model state $ \st -> recordProgress st key change + model stateModelIO k = do + state <- fromModel =<< stateModelIO + k state + toModel state + test name p = testCase name $ do + InProgressModel{..} <- p (done, todo) @?= (length (filter (==0) (Map.elems current)), Map.size current) - test name p = testCase name $ model p + +fromModel :: InProgressModel -> IO InProgressState +fromModel InProgressModel{..} = do + doneVar <- newTVarIO done + todoVar <- newTVarIO todo + currentVar <- STM.newIO + atomically $ for_ (Map.toList current) $ \(k,v) -> STM.insert v k currentVar + return InProgressState{..} + +toModel :: InProgressState -> IO InProgressModel +toModel InProgressState{..} = atomically $ do + done <- readTVar doneVar + todo <- readTVar todoVar + current <- Map.fromList <$> ListT.toList (STM.listT currentVar) + return InProgressModel{..} diff --git a/test/src/Development/IDE/Test.hs b/test/src/Development/IDE/Test.hs --- a/test/src/Development/IDE/Test.hs +++ b/test/src/Development/IDE/Test.hs @@ -29,14 +29,16 @@ , getStoredKeys , waitForCustomMessage , waitForGC - ,getBuildKeysBuilt,getBuildKeysVisited,getBuildKeysChanged,getBuildEdgesCount) where + ,getBuildKeysBuilt,getBuildKeysVisited,getBuildKeysChanged,getBuildEdgesCount,configureCheckProject) where import Control.Applicative.Combinators import Control.Lens hiding (List) import Control.Monad import Control.Monad.IO.Class +import Data.Aeson (toJSON) import qualified Data.Aeson as A import Data.Bifunctor (second) +import Data.Default import qualified Data.Map.Strict as Map import Data.Maybe (fromJust) import Data.Text (Text) @@ -45,7 +47,7 @@ WaitForIdeRuleResult, ideResultSuccess) import Development.IDE.Test.Diagnostic -import Ide.Plugin.Config (CheckParents) +import Ide.Plugin.Config (CheckParents, checkProject) import Language.LSP.Test hiding (message) import qualified Language.LSP.Test as LspTest import Language.LSP.Types hiding @@ -246,3 +248,9 @@ case A.fromJSON v of A.Success x -> Just x _ -> Nothing + +configureCheckProject :: Bool -> Session () +configureCheckProject overrideCheckProject = + sendNotification SWorkspaceDidChangeConfiguration + (DidChangeConfigurationParams $ toJSON + def{checkProject = overrideCheckProject}) diff --git a/test/src/Development/IDE/Test/Diagnostic.hs b/test/src/Development/IDE/Test/Diagnostic.hs --- a/test/src/Development/IDE/Test/Diagnostic.hs +++ b/test/src/Development/IDE/Test/Diagnostic.hs @@ -7,7 +7,7 @@ import Language.LSP.Types.Lens as Lsp -- | (0-based line number, 0-based column number) -type Cursor = (Int, Int) +type Cursor = (UInt, UInt) cursorPosition :: Cursor -> Position cursorPosition (line, col) = Position line col