packages feed

ghcide 1.5.0.1 → 1.6.0.0

raw patch · 97 files changed

+5259/−2518 lines, 97 filesdep +focusdep +list-tdep +randomdep −bytestring-encodingdep ~extradep ~hie-biosdep ~hls-graph

Dependencies added: focus, list-t, random, stm-containers

Dependencies removed: bytestring-encoding

Dependency ranges changed: extra, hie-bios, hls-graph, hls-plugin-api, implicit-hie-cradle, lsp, lsp-types

Files

bench/lib/Experiments.hs view
@@ -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
exe/Main.hs view
@@ -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
ghcide.cabal view
@@ -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,
session-loader/Development/IDE/Session.hs view
@@ -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))]
src/Control/Concurrent/Strict.hs view
@@ -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
src/Development/IDE/Core/Actions.hs view
@@ -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
src/Development/IDE/Core/Compile.hs view
@@ -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 =
src/Development/IDE/Core/Debouncer.hs view
@@ -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
src/Development/IDE/Core/FileExists.hs view
@@ -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.
src/Development/IDE/Core/FileStore.hs view
@@ -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
src/Development/IDE/Core/OfInterest.hs view
@@ -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"
src/Development/IDE/Core/PositionMapping.hs view
@@ -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
src/Development/IDE/Core/ProgressReporting.hs view
@@ -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
src/Development/IDE/Core/RuleTypes.hs view
@@ -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)
src/Development/IDE/Core/Rules.hs view
@@ -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
src/Development/IDE/Core/Service.hs view
@@ -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)
src/Development/IDE/Core/Shake.hs view
@@ -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
src/Development/IDE/Core/Tracing.hs view
@@ -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
src/Development/IDE/Core/UseStale.hs view
@@ -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)
+
src/Development/IDE/GHC/CPP.hs view
@@ -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
+
src/Development/IDE/GHC/Compat.hs view
@@ -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
src/Development/IDE/GHC/Compat/CPP.hs view
@@ -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
src/Development/IDE/GHC/Compat/Core.hs view
@@ -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
src/Development/IDE/GHC/Compat/Env.hs view
@@ -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
+ src/Development/IDE/GHC/Compat/ExactPrint.hs view
@@ -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
src/Development/IDE/GHC/Compat/Outputable.hs view
@@ -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 =
src/Development/IDE/GHC/Compat/Parser.hs view
@@ -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)
src/Development/IDE/GHC/Compat/Plugins.hs view
@@ -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
src/Development/IDE/GHC/Compat/Units.hs view
@@ -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
src/Development/IDE/GHC/Compat/Util.hs view
@@ -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
+ src/Development/IDE/GHC/Dump.hs view
@@ -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\");"+  , "  }); }"+  ]
src/Development/IDE/GHC/Error.hs view
@@ -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
src/Development/IDE/GHC/ExactPrint.hs view
@@ -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
src/Development/IDE/GHC/Orphans.hs view
@@ -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
src/Development/IDE/GHC/Util.hs view
@@ -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]++
src/Development/IDE/Import/DependencyInformation.hs view
@@ -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
src/Development/IDE/LSP/LanguageServer.hs view
@@ -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
src/Development/IDE/LSP/Notifications.hs view
@@ -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
src/Development/IDE/LSP/Outline.hs view
@@ -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
src/Development/IDE/Main.hs view
@@ -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 "."
+ src/Development/IDE/Main/HeapStats.hs view
@@ -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
src/Development/IDE/Plugin/CodeAction.hs view
@@ -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 "<dummy>" _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'
src/Development/IDE/Plugin/CodeAction/Args.hs view
@@ -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)
src/Development/IDE/Plugin/CodeAction/ExactPrint.hs view
@@ -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
src/Development/IDE/Plugin/Completions.hs view
@@ -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
src/Development/IDE/Plugin/Completions/Logic.hs view
@@ -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]
src/Development/IDE/Plugin/Completions/Types.hs view
@@ -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
src/Development/IDE/Plugin/Test.hs view
@@ -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
src/Development/IDE/Plugin/TypeLenses.hs view
@@ -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)
src/Development/IDE/Spans/AtPoint.hs view
@@ -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
src/Development/IDE/Spans/Documentation.hs view
@@ -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
src/Development/IDE/Spans/LocalBindings.hs view
@@ -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 _ = "<bindings>"------------------------------------------------------------------------------------ | 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 _ = "<bindings>"
+
+
+------------------------------------------------------------------------------
+-- | 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
+
+ src/Development/IDE/Spans/Pragmas.hs view
@@ -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 -}<space><tab><tab><space>-- | 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
src/Development/IDE/Types/Diagnostics.hs view
@@ -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
src/Development/IDE/Types/Exports.hs view
@@ -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
src/Development/IDE/Types/HscEnvEq.hs view
@@ -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)
src/Development/IDE/Types/Logger.hs view
@@ -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
src/Development/IDE/Types/Shake.hs view
@@ -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
src/Generics/SYB/GHC.hs view
@@ -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)
src/Text/Fuzzy/Parallel.hs view
@@ -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)
− 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 
@@ -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)
+ test/data/import-placement/MultiLinePragma.expected.hs view
@@ -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
+ test/data/import-placement/MultiLinePragma.hs view
@@ -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
+ test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs view
@@ -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
+ test/data/import-placement/OptionsNotAtTopWithSpaces.hs view
@@ -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
+ test/data/import-placement/OptionsPragmaNotAtTop.expected.hs view
@@ -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
+ test/data/import-placement/OptionsPragmaNotAtTop.hs view
@@ -0,0 +1,7 @@+class Semigroup a => SomeData a+instance SomeData All++{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++addOne :: Int -> Int+addOne x = x + 1
+ test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs view
@@ -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
+ test/data/import-placement/PragmaNotAtTopMultipleComments.hs view
@@ -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
+ test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs view
@@ -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
+ test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.hs view
@@ -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
+ test/data/import-placement/PragmaNotAtTopWithImports.expected.hs view
@@ -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
+ test/data/import-placement/PragmaNotAtTopWithImports.hs view
@@ -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
+ test/data/import-placement/PragmaNotAtTopWithModuleDecl.expected.hs view
@@ -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
+ test/data/import-placement/PragmaNotAtTopWithModuleDecl.hs view
@@ -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
+ test/data/import-placement/ShebangNotAtTop.expected.hs view
@@ -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
+ test/data/import-placement/ShebangNotAtTop.hs view
@@ -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
+ test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs view
@@ -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
+ test/data/import-placement/ShebangNotAtTopNoSpace.hs view
@@ -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
+ test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs view
@@ -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
+ test/data/import-placement/ShebangNotAtTopWithSpaces.hs view
@@ -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
+ test/data/import-placement/WhereDeclLowerInFile.expected.hs view
@@ -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
+ test/data/import-placement/WhereDeclLowerInFile.hs view
@@ -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
+ test/data/import-placement/WhereKeywordLowerInFileNoExports.expected.hs view
@@ -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
+ test/data/import-placement/WhereKeywordLowerInFileNoExports.hs view
@@ -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
− test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.2/a-1.0.0/build/autogen/Paths_a.hs 
@@ -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)
− test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-1.0.0/build/autogen/Paths_a.hs 
@@ -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)
− test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/b-1.0.0/build/autogen/Paths_b.hs 
@@ -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)
test/data/plugin-knownnat/cabal.project view
@@ -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
+ test/data/symlink/hie.yaml view
@@ -0,0 +1,10 @@++cradle:+  direct:+    arguments:+      - -i+      - -isrc+      - -iother_loc/+      - other_loc/Sym.hs+      - src/Foo.hs+      - -Wall
+ test/data/symlink/some_loc/Sym.hs view
@@ -0,0 +1,4 @@+module Sym where++foo :: String+foo = ""
+ test/data/symlink/src/Foo.hs view
@@ -0,0 +1,4 @@+module Foo where++import Sym+
+ test/exe/HieDbRetry.hs view
@@ -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"+  ]
test/exe/Main.hs view
@@ -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
test/exe/Progress.hs view
@@ -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{..}
test/src/Development/IDE/Test.hs view
@@ -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})
test/src/Development/IDE/Test/Diagnostic.hs view
@@ -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