diff --git a/ghcide.cabal b/ghcide.cabal --- a/ghcide.cabal +++ b/ghcide.cabal @@ -2,7 +2,7 @@ build-type: Simple category: Development name: ghcide -version: 1.5.0 +version: 1.5.0.1 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors @@ -60,7 +60,7 @@ haddock-library >= 1.8 && < 1.11, hashable, hie-compat ^>= 0.2.0.0, - hls-plugin-api ^>= 1.2.0.0, + hls-plugin-api ^>= 1.2.0.2, lens, hiedb == 0.4.1.*, lsp-types >= 1.3.0.1 && < 1.4, @@ -71,7 +71,7 @@ optparse-applicative, parallel, prettyprinter-ansi-terminal, - prettyprinter >= 1.7, + prettyprinter, regex-tdfa >= 1.3.1.0, retrie, rope-utf16-splay, diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -106,7 +106,7 @@ import Data.Tuple.Extra (dupe) import Data.Unique as Unique import Development.IDE.Core.Tracing (withTrace) -import Development.IDE.GHC.Compat.Util (emptyUDFM, plusUDFM) +import Development.IDE.GHC.Compat.Util (emptyUDFM, plusUDFM_C) import qualified Language.LSP.Server as LSP import qualified Language.LSP.Types as LSP import Unsafe.Coerce @@ -702,11 +702,15 @@ (\fc (im, ifr) -> Compat.extendInstalledModuleEnv fc im ifr) prevFinderCache $ zip ims ifrs return $ loadModulesHome extraMods $ env{ - hsc_HPT = foldMapBy plusUDFM emptyUDFM hsc_HPT envs, + 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) } where + mergeUDFM = plusUDFM_C combineModules + combineModules a b + | HsSrcFile <- mi_hsc_src (hm_iface a) = a + | otherwise = b -- required because 'FinderCache': -- 1) doesn't have a 'Monoid' instance, -- 2) is abstract and doesn't export constructors diff --git a/src/Development/IDE/Core/RuleTypes.hs b/src/Development/IDE/Core/RuleTypes.hs --- a/src/Development/IDE/Core/RuleTypes.hs +++ b/src/Development/IDE/Core/RuleTypes.hs @@ -252,10 +252,6 @@ -- | Get a module interface details, either from an interface file or a typechecked module type instance RuleResult GetModIface = HiFileResult --- | Get a module interface details, without the Linkable --- For better early cuttoff -type instance RuleResult GetModIfaceWithoutLinkable = HiFileResult - -- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk. type instance RuleResult GetFileContents = (FileVersion, Maybe Text) @@ -429,11 +425,6 @@ deriving (Eq, Show, Typeable, Generic) instance Hashable GetModIface instance NFData GetModIface - -data GetModIfaceWithoutLinkable = GetModIfaceWithoutLinkable - deriving (Eq, Show, Typeable, Generic) -instance Hashable GetModIfaceWithoutLinkable -instance NFData GetModIfaceWithoutLinkable data IsFileOfInterest = IsFileOfInterest deriving (Eq, Show, Typeable, Generic) diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -41,7 +41,6 @@ loadGhcSession, getModIfaceFromDiskRule, getModIfaceRule, - getModIfaceWithoutLinkableRule, getModSummaryRule, isHiFileStableRule, getModuleGraphRule, @@ -349,7 +348,22 @@ Left diags -> pure (diags, Just (modName, Nothing)) Right (FileImport path) -> pure ([], Just (modName, Just path)) Right PackageImport -> pure ([], Nothing) - let moduleImports = catMaybes imports' + + {- IS THIS REALLY NEEDED? DOESNT SEEM SO + + -- does this module have an hs-boot file? If so add a direct dependency + let bootPath = toNormalizedFilePath' $ fromNormalizedFilePath file <.> "hs-boot" + boot <- use GetFileExists bootPath + bootArtifact <- if boot == Just True + then do + let modName = ms_mod_name ms + loc <- liftIO $ mkHomeModLocation dflags modName (fromNormalizedFilePath bootPath) + return $ Just (noLoc modName, Just (ArtifactsLocation bootPath (Just loc) True)) + else pure Nothing + -} + let bootArtifact = Nothing + + let moduleImports = catMaybes $ bootArtifact : imports' pure (concat diags, Just moduleImports) type RawDepM a = StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action a @@ -375,7 +389,7 @@ go :: NormalizedFilePath -- ^ Current module being processed -> Maybe ModSummary -- ^ ModSummary of the module - -> StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action FilePathId + -> RawDepM FilePathId go f msum = do -- First check to see if we have already processed the FilePath -- If we have, just return its Id but don't update any of the state. @@ -688,13 +702,11 @@ data GhcSessionDepsConfig = GhcSessionDepsConfig { checkForImportCycles :: Bool - , forceLinkables :: Bool , fullModSummary :: Bool } instance Default GhcSessionDepsConfig where def = GhcSessionDepsConfig { checkForImportCycles = True - , forceLinkables = False , fullModSummary = False } @@ -707,17 +719,12 @@ Nothing -> return Nothing Just deps -> do when checkForImportCycles $ void $ uses_ ReportImportCycles deps - ms:mss <- map msrModSummary <$> if fullModSummary - then uses_ GetModSummary (file:deps) - else uses_ GetModSummaryWithoutTimestamps (file:deps) + mss <- map msrModSummary <$> if fullModSummary + then uses_ GetModSummary deps + else uses_ GetModSummaryWithoutTimestamps deps depSessions <- map hscEnv <$> uses_ GhcSessionDeps deps - let uses_th_qq = - xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags - dflags = ms_hspp_opts ms - ifaces <- if uses_th_qq || forceLinkables - then uses_ GetModIface deps - else uses_ GetModIfaceWithoutLinkable deps + ifaces <- uses_ GetModIface deps let inLoadOrder = map hirHomeMod ifaces session' <- liftIO $ mergeEnvs hsc mss inLoadOrder depSessions @@ -882,13 +889,6 @@ liftIO $ void $ modifyVar' compiledLinkables $ \old -> extendModuleEnv old mod time pure res -getModIfaceWithoutLinkableRule :: Rules () -getModIfaceWithoutLinkableRule = defineEarlyCutoff $ RuleNoDiagnostics $ \GetModIfaceWithoutLinkable f -> do - mhfr <- use GetModIface f - let mhfr' = fmap (\x -> x{ hirHomeMod = (hirHomeMod x){ hm_linkable = Just (error msg) } }) mhfr - msg = "tried to look at linkable for GetModIfaceWithoutLinkable for " ++ show f - pure (hirIfaceFp <$> mhfr', mhfr') - -- | Also generates and indexes the `.hie` file, along with the `.o` file if needed -- Invariant maintained is that if the `.hi` file was successfully written, then the -- `.hie` and `.o` file (if needed) were also successfully written @@ -1089,7 +1089,6 @@ getModIfaceFromDiskRule getModIfaceFromDiskAndIndexRule getModIfaceRule - getModIfaceWithoutLinkableRule getModSummaryRule isHiFileStableRule getModuleGraphRule diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs --- a/src/Development/IDE/Core/Shake.hs +++ b/src/Development/IDE/Core/Shake.hs @@ -618,11 +618,13 @@ (stopTime,()) <- duration (cancelShakeSession runner) res <- shakeDatabaseProfile shakeDb backlog <- readIORef $ dirtyKeys shakeExtras + queue <- atomically $ peekInProgress $ actionQueue shakeExtras let profile = case res of Just fp -> ", profile saved at " <> fp _ -> "" - let msg = T.pack $ "Restarting build session " ++ reason' ++ keysMsg ++ abortMsg + let msg = T.pack $ "Restarting build session " ++ reason' ++ queueMsg ++ keysMsg ++ abortMsg reason' = "due to " ++ reason + queueMsg = " with queue " ++ show (map actionName queue) keysMsg = " for keys " ++ show (HSet.toList backlog) ++ " " abortMsg = "(aborting the previous one took " ++ showDuration stopTime ++ profile ++ ")" logDebug (logger shakeExtras) msg @@ -700,7 +702,8 @@ -- The inferred type signature doesn't work in ghc >= 9.0.1 workRun :: (forall b. IO b -> IO b) -> IO (IO ()) workRun restore = withSpan "Shake session" $ \otSpan -> do - setTag otSpan "_reason" (fromString reason) + setTag otSpan "reason" (fromString reason) + setTag otSpan "queue" (fromString $ unlines $ map actionName reenqueued) whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show $ toList kk) let keysActs = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts) res <- try @SomeException $ @@ -893,7 +896,7 @@ -- Async trigger the key to be built anyway because we want to -- keep updating the value in the key. - wait <- delayedAction $ mkDelayedAction ("C:" ++ show key) Debug $ use key file + wait <- delayedAction $ mkDelayedAction ("C:" ++ show key ++ ":" ++ fromNormalizedFilePath file) Debug $ use key file s@ShakeExtras{state} <- askShake r <- liftIO $ getValues state key file diff --git a/src/Development/IDE/GHC/Compat/Util.hs b/src/Development/IDE/GHC/Compat/Util.hs --- a/src/Development/IDE/GHC/Compat/Util.hs +++ b/src/Development/IDE/GHC/Compat/Util.hs @@ -62,6 +62,7 @@ -- * UniqDFM emptyUDFM, plusUDFM, + plusUDFM_C, -- * String Buffer StringBuffer(..), hGetStringBuffer, diff --git a/src/Development/IDE/Types/Diagnostics.hs b/src/Development/IDE/Types/Diagnostics.hs --- a/src/Development/IDE/Types/Diagnostics.hs +++ b/src/Development/IDE/Types/Diagnostics.hs @@ -19,10 +19,10 @@ import Control.DeepSeq import Data.Maybe as Maybe import qualified Data.Text as T -import Prettyprinter -import Prettyprinter.Render.Terminal (Color (..), color) -import qualified Prettyprinter.Render.Terminal as Terminal -import Prettyprinter.Render.Text +import Data.Text.Prettyprint.Doc +import Data.Text.Prettyprint.Doc.Render.Terminal (Color (..), color) +import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Terminal +import Data.Text.Prettyprint.Doc.Render.Text import Language.LSP.Diagnostics import Language.LSP.Types as LSP (Diagnostic (..), DiagnosticSeverity (..), diff --git a/test/data/THLoading/A.hs b/test/data/THLoading/A.hs new file mode 100644 --- /dev/null +++ b/test/data/THLoading/A.hs @@ -0,0 +1,5 @@ +module A where +import B (bar) + +foo :: () +foo = bar diff --git a/test/data/THLoading/B.hs b/test/data/THLoading/B.hs new file mode 100644 --- /dev/null +++ b/test/data/THLoading/B.hs @@ -0,0 +1,4 @@ +module B where + +bar :: () +bar = () diff --git a/test/data/THLoading/THA.hs b/test/data/THLoading/THA.hs new file mode 100644 --- /dev/null +++ b/test/data/THLoading/THA.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module THA where +import Language.Haskell.TH +import A (foo) + +th_a :: DecsQ +th_a = [d| a = foo |] diff --git a/test/data/THLoading/THB.hs b/test/data/THLoading/THB.hs new file mode 100644 --- /dev/null +++ b/test/data/THLoading/THB.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +module THB where +import THA + +$th_a diff --git a/test/data/THLoading/hie.yaml b/test/data/THLoading/hie.yaml new file mode 100644 --- /dev/null +++ b/test/data/THLoading/hie.yaml @@ -0,0 +1,1 @@ +cradle: {direct: {arguments: ["-package template-haskell", "THA", "THB", "A", "B"]}} diff --git a/test/data/boot2/A.hs b/test/data/boot2/A.hs new file mode 100644 --- /dev/null +++ b/test/data/boot2/A.hs @@ -0,0 +1,12 @@ +module A where + +-- E source imports B +-- In interface file see source module dependencies: B {-# SOURCE #-} +import E +-- C imports B +-- In interface file see source module dependencies: B +import C + +-- Instance for B only available from B.hi not B.hi-boot, so tests we load +-- that. +main = print B diff --git a/test/data/boot2/B.hs b/test/data/boot2/B.hs new file mode 100644 --- /dev/null +++ b/test/data/boot2/B.hs @@ -0,0 +1,8 @@ +module B where + +import D + +data B = B + +instance Show B where + show B = "B" diff --git a/test/data/boot2/B.hs-boot b/test/data/boot2/B.hs-boot new file mode 100644 --- /dev/null +++ b/test/data/boot2/B.hs-boot @@ -0,0 +1,3 @@ +module B where + +data B = B diff --git a/test/data/boot2/C.hs b/test/data/boot2/C.hs new file mode 100644 --- /dev/null +++ b/test/data/boot2/C.hs @@ -0,0 +1,3 @@ +module C where + +import B diff --git a/test/data/boot2/D.hs b/test/data/boot2/D.hs new file mode 100644 --- /dev/null +++ b/test/data/boot2/D.hs @@ -0,0 +1,3 @@ +module D where + +import {-# SOURCE #-} B diff --git a/test/data/boot2/E.hs b/test/data/boot2/E.hs new file mode 100644 --- /dev/null +++ b/test/data/boot2/E.hs @@ -0,0 +1,3 @@ +module E(B(B)) where + +import {-# SOURCE #-} B diff --git a/test/data/boot2/hie.yaml b/test/data/boot2/hie.yaml new file mode 100644 --- /dev/null +++ b/test/data/boot2/hie.yaml @@ -0,0 +1,1 @@ +cradle: {direct: {arguments: ["A.hs", "B.hs-boot", "B.hs", "C.hs", "D.hs", "E.hs"]}} diff --git a/test/data/cabal-exe/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-0.1.0.0/x/a/build/a/autogen/Paths_a.hs b/test/data/cabal-exe/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-0.1.0.0/x/a/build/a/autogen/Paths_a.hs new file mode 100644 --- /dev/null +++ b/test/data/cabal-exe/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-0.1.0.0/x/a/build/a/autogen/Paths_a.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoRebindableSyntax #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +module Paths_a ( + version, + getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, + getDataFileName, getSysconfDir + ) where + +import qualified Control.Exception as Exception +import Data.Version (Version(..)) +import System.Environment (getEnv) +import Prelude + +#if defined(VERSION_base) + +#if MIN_VERSION_base(4,0,0) +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#else +catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a +#endif + +#else +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#endif +catchIO = Exception.catch + +version :: Version +version = Version [0,1,0,0] [] +bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath + +bindir = "/Users/pepeiborra/.cabal/bin" +libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3/a-0.1.0.0-inplace-a" +dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3" +datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.3/a-0.1.0.0" +libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.3/a-0.1.0.0" +sysconfdir = "/Users/pepeiborra/.cabal/etc" + +getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath +getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir) +getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir) +getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir) +getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir) +getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir) +getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir) + +getDataFileName :: FilePath -> IO FilePath +getDataFileName name = do + dir <- getDataDir + return (dir ++ "/" ++ name) diff --git a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.2/a-1.0.0/build/autogen/Paths_a.hs b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.2/a-1.0.0/build/autogen/Paths_a.hs new file mode 100644 --- /dev/null +++ b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.2/a-1.0.0/build/autogen/Paths_a.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoRebindableSyntax #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +module Paths_a ( + version, + getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, + getDataFileName, getSysconfDir + ) where + +import qualified Control.Exception as Exception +import Data.Version (Version(..)) +import System.Environment (getEnv) +import Prelude + +#if defined(VERSION_base) + +#if MIN_VERSION_base(4,0,0) +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#else +catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a +#endif + +#else +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#endif +catchIO = Exception.catch + +version :: Version +version = Version [1,0,0] [] +bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath + +bindir = "/Users/pepeiborra/.cabal/bin" +libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.2/a-1.0.0-inplace" +dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.2" +datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.2/a-1.0.0" +libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.2/a-1.0.0" +sysconfdir = "/Users/pepeiborra/.cabal/etc" + +getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath +getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir) +getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir) +getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir) +getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir) +getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir) +getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir) + +getDataFileName :: FilePath -> IO FilePath +getDataFileName name = do + dir <- getDataDir + return (dir ++ "/" ++ name) diff --git a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-1.0.0/build/autogen/Paths_a.hs b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-1.0.0/build/autogen/Paths_a.hs new file mode 100644 --- /dev/null +++ b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-1.0.0/build/autogen/Paths_a.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoRebindableSyntax #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +module Paths_a ( + version, + getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, + getDataFileName, getSysconfDir + ) where + +import qualified Control.Exception as Exception +import Data.Version (Version(..)) +import System.Environment (getEnv) +import Prelude + +#if defined(VERSION_base) + +#if MIN_VERSION_base(4,0,0) +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#else +catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a +#endif + +#else +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#endif +catchIO = Exception.catch + +version :: Version +version = Version [1,0,0] [] +bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath + +bindir = "/Users/pepeiborra/.cabal/bin" +libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3/a-1.0.0-inplace" +dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3" +datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.3/a-1.0.0" +libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.3/a-1.0.0" +sysconfdir = "/Users/pepeiborra/.cabal/etc" + +getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath +getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir) +getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir) +getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir) +getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir) +getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir) +getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir) + +getDataFileName :: FilePath -> IO FilePath +getDataFileName name = do + dir <- getDataDir + return (dir ++ "/" ++ name) diff --git a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/b-1.0.0/build/autogen/Paths_b.hs b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/b-1.0.0/build/autogen/Paths_b.hs new file mode 100644 --- /dev/null +++ b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/b-1.0.0/build/autogen/Paths_b.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoRebindableSyntax #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +module Paths_b ( + version, + getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, + getDataFileName, getSysconfDir + ) where + +import qualified Control.Exception as Exception +import Data.Version (Version(..)) +import System.Environment (getEnv) +import Prelude + +#if defined(VERSION_base) + +#if MIN_VERSION_base(4,0,0) +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#else +catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a +#endif + +#else +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#endif +catchIO = Exception.catch + +version :: Version +version = Version [1,0,0] [] +bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath + +bindir = "/Users/pepeiborra/.cabal/bin" +libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3/b-1.0.0-inplace" +dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3" +datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.3/b-1.0.0" +libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.3/b-1.0.0" +sysconfdir = "/Users/pepeiborra/.cabal/etc" + +getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath +getBinDir = catchIO (getEnv "b_bindir") (\_ -> return bindir) +getLibDir = catchIO (getEnv "b_libdir") (\_ -> return libdir) +getDynLibDir = catchIO (getEnv "b_dynlibdir") (\_ -> return dynlibdir) +getDataDir = catchIO (getEnv "b_datadir") (\_ -> return datadir) +getLibexecDir = catchIO (getEnv "b_libexecdir") (\_ -> return libexecdir) +getSysconfDir = catchIO (getEnv "b_sysconfdir") (\_ -> return sysconfdir) + +getDataFileName :: FilePath -> IO FilePath +getDataFileName name = do + dir <- getDataDir + return (dir ++ "/" ++ name) diff --git a/test/exe/Main.hs b/test/exe/Main.hs --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -4018,6 +4018,7 @@ _ <- createDoc "B.hs" "haskell" sourceB return () , thReloadingTest False + , thLoadingTest , ignoreInWindowsBecause "Broken in windows" $ thReloadingTest True -- Regression test for https://github.com/haskell/haskell-language-server/issues/891 , thLinkingTest False @@ -4055,6 +4056,14 @@ expectDiagnostics [ ( cPath, [(DsWarning, (3, 0), "Top-level binding with no type signature: a :: A")] ) ] ] +-- | Test that all modules have linkables +thLoadingTest :: TestTree +thLoadingTest = testCase "Loading linkables" $ runWithExtraFiles "THLoading" $ \dir -> do + let thb = dir "THB.hs" + _ <- openDoc thb "haskell" + expectNoMoreDiagnostics 1 + + -- | test that TH is reevaluated on typecheck thReloadingTest :: Bool -> TestTree thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do @@ -5268,25 +5277,28 @@ ] bootTests :: TestTree -bootTests = testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do - let cPath = dir "C.hs" - cSource <- liftIO $ readFileUtf8 cPath - - -- Dirty the cache - liftIO $ runInDir dir $ do - cDoc <- createDoc cPath "haskell" cSource - _ <- getHover cDoc $ Position 4 3 - ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = fp}) -> do - A.Success fp' <- pure $ fromJSON fp - if equalFilePath fp' cPath then pure () else Nothing - _ -> Nothing - closeDoc cDoc - - cdoc <- createDoc cPath "haskell" cSource - locs <- getDefinitions cdoc (Position 7 4) - let floc = mkR 9 0 9 1 - checkDefs locs (pure [floc]) +bootTests = testGroup "boot" + [ testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do + let cPath = dir "C.hs" + cSource <- liftIO $ readFileUtf8 cPath + -- Dirty the cache + liftIO $ runInDir dir $ do + cDoc <- createDoc cPath "haskell" cSource + _ <- getHover cDoc $ Position 4 3 + ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = fp}) -> do + A.Success fp' <- pure $ fromJSON fp + if equalFilePath fp' cPath then pure () else Nothing + _ -> Nothing + closeDoc cDoc + cdoc <- createDoc cPath "haskell" cSource + locs <- getDefinitions cdoc (Position 7 4) + let floc = mkR 9 0 9 1 + checkDefs locs (pure [floc]) + , testCase "graph with boot modules" $ runWithExtraFiles "boot2" $ \dir -> do + _ <- openDoc (dir "A.hs") "haskell" + expectNoMoreDiagnostics 2 + ] -- | test that TH reevaluates across interfaces ifaceTHTest :: TestTree