Skip to content

Commit df63fd7

Browse files
pepeiborrapepeiborra
authored
Tests for cradle loading (#460)
* Refactor: extract Rules to a separate module * Add tests for cradle loading * Fix default extensions in exe target * Move cradle loaded messages behind a flag * Use satisfy Following a suggestion by Moritz Kiefer (@cocreature)
1 parent 47a338f commit df63fd7

File tree

8 files changed

+225
-125
lines changed

8 files changed

+225
-125
lines changed

‎exe/Arguments.hs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,7 @@ data Arguments = Arguments
1212
,argFiles :: [FilePath]
1313
,argsVersion :: Bool
1414
,argsShakeProfiling :: Maybe FilePath
15+
,argsTesting :: Bool
1516
}
1617

1718
getArguments :: IO Arguments
@@ -29,3 +30,4 @@ arguments = Arguments
2930
<*> many (argument str (metavar "FILES/DIRS..."))
3031
<*> switch (long "version" <> help "Show ghcide and GHC versions")
3132
<*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory")
33+
<*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite")

‎exe/Main.hs

Lines changed: 4 additions & 117 deletions
Original file line numberDiff line numberDiff line change
@@ -8,17 +8,13 @@
88
module Main(main) where
99

1010
import Arguments
11-
import Data.Functor ((<&>))
1211
import Data.Maybe
1312
import Data.List.Extra
1413
import System.FilePath
1514
import Control.Concurrent.Extra
1615
import Control.Exception
1716
import Control.Monad.Extra
1817
import Control.Monad.IO.Class
19-
import qualified Crypto.Hash.SHA1 as H
20-
import qualified Data.ByteString.Char8 as B
21-
import Data.ByteString.Base16
2218
import Data.Default
2319
import System.Time.Extra
2420
import Development.IDE.Core.Debouncer
@@ -41,7 +37,6 @@ import qualified Data.Text as T
4137
import qualified Data.Text.IO as T
4238
import Language.Haskell.LSP.Messages
4339
import Language.Haskell.LSP.Types (LspId(IdInt))
44-
import Linker
4540
import Data.Version
4641
import Development.IDE.LSP.LanguageServer
4742
import qualified System.Directory.Extra as IO
@@ -50,35 +45,13 @@ import System.IO
5045
import System.Exit
5146
import Paths_ghcide
5247
import Development.GitRev
53-
import Development.Shake (doesDirectoryExist, Action, Rules, action, doesFileExist, need)
48+
import Development.Shake (Action, Rules, action)
5449
import qualified Data.HashSet as HashSet
5550
import qualified Data.Map.Strict as Map
56-
57-
import GHC hiding (def)
58-
import qualified GHC.Paths
59-
import DynFlags
60-
61-
import HIE.Bios.Environment
6251
import HIE.Bios
63-
import HIE.Bios.Cradle
64-
import HIE.Bios.Types
52+
import Rules
6553
import RuleTypes
6654

67-
-- Prefix for the cache path
68-
cacheDir :: String
69-
cacheDir = "ghcide"
70-
71-
-- Set the GHC libdir to the nix libdir if it's present.
72-
getLibdir :: IO FilePath
73-
getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"
74-
75-
getCacheDir :: [String] -> IO FilePath
76-
getCacheDir opts = IO.getXdgDirectory IO.XdgCache (cacheDir </> opts_hash)
77-
where
78-
-- Create a unique folder per set of different GHC options, assuming that each different set of
79-
-- GHC options will create incompatible interface files.
80-
opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init (map B.pack opts)
81-
8255
ghcideVersion :: IO String
8356
ghcideVersion = do
8457
path <- getExecutablePath
@@ -122,6 +95,7 @@ main = do
12295
let options = (defaultIdeOptions $ loadSession dir)
12396
{ optReportProgress = clientSupportsProgress caps
12497
, optShakeProfiling = argsShakeProfiling
98+
, optTesting = IdeTesting argsTesting
12599
}
126100
debouncer <- newAsyncDebouncer
127101
initialise caps (cradleRules >> mainRule >> pluginRules plugins >> action kick)
@@ -177,7 +151,7 @@ main = do
177151

178152
cradleRules :: Rules ()
179153
cradleRules = do
180-
loadGhcSessionIO
154+
loadGhcSession
181155
cradleToSession
182156

183157
expandFiles :: [FilePath] -> IO [FilePath]
@@ -205,93 +179,6 @@ showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =
205179
withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags
206180
showEvent lock e = withLock lock $ print e
207181

208-
loadGhcSessionIO :: Rules ()
209-
loadGhcSessionIO =
210-
-- This rule is for caching the GHC session. E.g., even when the cabal file
211-
-- changed, if the resulting flags did not change, we would continue to use
212-
-- the existing session.
213-
defineNoFile $ \(GetHscEnv opts deps) ->
214-
liftIO $ createSession $ ComponentOptions opts deps
215-
216-
getComponentOptions :: Cradle a -> IO ComponentOptions
217-
getComponentOptions cradle = do
218-
let showLine s = putStrLn ("> " ++ s)
219-
-- WARNING 'runCradle is very expensive and must be called as few times as possible
220-
cradleRes <- runCradle (cradleOptsProg cradle) showLine ""
221-
case cradleRes of
222-
CradleSuccess r -> pure r
223-
CradleFail err -> throwIO err
224-
-- TODO Rather than failing here, we should ignore any files that use this cradle.
225-
-- That will require some more changes.
226-
CradleNone -> fail "'none' cradle is not yet supported"
227-
228-
229-
createSession :: ComponentOptions -> IO HscEnvEq
230-
createSession (ComponentOptions theOpts _) = do
231-
libdir <- getLibdir
232-
233-
cacheDir <- Main.getCacheDir theOpts
234-
235-
env <- runGhc (Just libdir) $ do
236-
dflags <- getSessionDynFlags
237-
(dflags', _targets) <- addCmdOpts theOpts dflags
238-
_ <- setSessionDynFlags $
239-
-- disabled, generated directly by ghcide instead
240-
flip gopt_unset Opt_WriteInterface $
241-
-- disabled, generated directly by ghcide instead
242-
-- also, it can confuse the interface stale check
243-
dontWriteHieFiles $
244-
setHiDir cacheDir $
245-
setDefaultHieDir cacheDir $
246-
setIgnoreInterfacePragmas $
247-
setLinkerOptions $
248-
disableOptimisation dflags'
249-
getSession
250-
initDynLinker env
251-
newHscEnvEq env
252-
253-
-- we don't want to generate object code so we compile to bytecode
254-
-- (HscInterpreted) which implies LinkInMemory
255-
-- HscInterpreted
256-
setLinkerOptions :: DynFlags -> DynFlags
257-
setLinkerOptions df = df {
258-
ghcLink = LinkInMemory
259-
, hscTarget = HscNothing
260-
, ghcMode = CompManager
261-
}
262-
263-
setIgnoreInterfacePragmas :: DynFlags -> DynFlags
264-
setIgnoreInterfacePragmas df =
265-
gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges
266-
267-
disableOptimisation :: DynFlags -> DynFlags
268-
disableOptimisation df = updOptLevel 0 df
269-
270-
setHiDir :: FilePath -> DynFlags -> DynFlags
271-
setHiDir f d =
272-
-- override user settings to avoid conflicts leading to recompilation
273-
d { hiDir = Just f}
274-
275-
cradleToSession :: Rules ()
276-
cradleToSession = define $ \LoadCradle nfp -> do
277-
let f = fromNormalizedFilePath nfp
278-
279-
-- If the path points to a directory, load the implicit cradle
280-
mbYaml <- doesDirectoryExist f <&> \isDir -> if isDir then Nothing else Just f
281-
cradle <- liftIO $ maybe (loadImplicitCradle $ addTrailingPathSeparator f) loadCradle mbYaml
282-
283-
cmpOpts <- liftIO $ getComponentOptions cradle
284-
let opts = componentOptions cmpOpts
285-
deps = componentDependencies cmpOpts
286-
deps' = case mbYaml of
287-
-- For direct cradles, the hie.yaml file itself must be watched.
288-
Just yaml | isDirectCradle cradle -> yaml : deps
289-
_ -> deps
290-
existingDeps <- filterM doesFileExist deps'
291-
need existingDeps
292-
([],) . pure <$> useNoFile_ (GetHscEnv opts deps)
293-
294-
295182
loadSession :: FilePath -> Action (FilePath -> Action HscEnvEq)
296183
loadSession dir = liftIO $ do
297184
cradleLoc <- memoIO $ \v -> do

‎exe/Rules.hs

Lines changed: 153 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,153 @@
1+
module Rules
2+
( loadGhcSession
3+
, cradleToSession
4+
, cradleLoadedMethod
5+
, createSession
6+
, getComponentOptions
7+
)
8+
where
9+
10+
import Control.Exception
11+
import Control.Monad (filterM, when)
12+
import qualified Crypto.Hash.SHA1 as H
13+
import Data.ByteString.Base16 (encode)
14+
import qualified Data.ByteString.Char8 as B
15+
import Data.Functor ((<&>))
16+
import Data.Maybe (fromMaybe)
17+
import Data.Text (Text)
18+
import Development.IDE.Core.Rules (defineNoFile)
19+
import Development.IDE.Core.Shake (ShakeExtras(ShakeExtras,isTesting), getShakeExtras, sendEvent, define, useNoFile_)
20+
import Development.IDE.GHC.Util
21+
import Development.IDE.Types.Location (fromNormalizedFilePath)
22+
import Development.Shake
23+
import DynFlags (gopt_set, gopt_unset,
24+
updOptLevel)
25+
import GHC
26+
import qualified GHC.Paths
27+
import HIE.Bios
28+
import HIE.Bios.Cradle
29+
import HIE.Bios.Environment (addCmdOpts)
30+
import HIE.Bios.Types
31+
import Linker (initDynLinker)
32+
import RuleTypes
33+
import qualified System.Directory.Extra as IO
34+
import System.Environment (lookupEnv)
35+
import System.FilePath.Posix (addTrailingPathSeparator,
36+
(</>))
37+
import Language.Haskell.LSP.Messages as LSP
38+
import Language.Haskell.LSP.Types as LSP
39+
import Data.Aeson (ToJSON(toJSON))
40+
41+
-- Prefix for the cache path
42+
cacheDir :: String
43+
cacheDir = "ghcide"
44+
45+
notifyCradleLoaded :: FilePath -> LSP.FromServerMessage
46+
notifyCradleLoaded fp =
47+
LSP.NotCustomServer $
48+
LSP.NotificationMessage "2.0" (LSP.CustomServerMethod cradleLoadedMethod) $
49+
toJSON fp
50+
51+
loadGhcSession :: Rules ()
52+
loadGhcSession =
53+
-- This rule is for caching the GHC session. E.g., even when the cabal file
54+
-- changed, if the resulting flags did not change, we would continue to use
55+
-- the existing session.
56+
defineNoFile $ \(GetHscEnv opts deps) ->
57+
liftIO $ createSession $ ComponentOptions opts deps
58+
59+
cradleToSession :: Rules ()
60+
cradleToSession = define $ \LoadCradle nfp -> do
61+
let f = fromNormalizedFilePath nfp
62+
63+
ShakeExtras{isTesting} <- getShakeExtras
64+
65+
-- If the path points to a directory, load the implicit cradle
66+
mbYaml <- doesDirectoryExist f <&> \isDir -> if isDir then Nothing else Just f
67+
cradle <- liftIO $ maybe (loadImplicitCradle $ addTrailingPathSeparator f) loadCradle mbYaml
68+
69+
when isTesting $
70+
sendEvent $ notifyCradleLoaded f
71+
72+
cmpOpts <- liftIO $ getComponentOptions cradle
73+
let opts = componentOptions cmpOpts
74+
deps = componentDependencies cmpOpts
75+
deps' = case mbYaml of
76+
-- For direct cradles, the hie.yaml file itself must be watched.
77+
Just yaml | isDirectCradle cradle -> yaml : deps
78+
_ -> deps
79+
existingDeps <- filterM doesFileExist deps'
80+
need existingDeps
81+
([],) . pure <$> useNoFile_ (GetHscEnv opts deps)
82+
83+
cradleLoadedMethod :: Text
84+
cradleLoadedMethod = "ghcide/cradle/loaded"
85+
86+
getComponentOptions :: Cradle a -> IO ComponentOptions
87+
getComponentOptions cradle = do
88+
let showLine s = putStrLn ("> " ++ s)
89+
-- WARNING 'runCradle is very expensive and must be called as few times as possible
90+
cradleRes <- runCradle (cradleOptsProg cradle) showLine ""
91+
case cradleRes of
92+
CradleSuccess r -> pure r
93+
CradleFail err -> throwIO err
94+
-- TODO Rather than failing here, we should ignore any files that use this cradle.
95+
-- That will require some more changes.
96+
CradleNone -> fail "'none' cradle is not yet supported"
97+
98+
createSession :: ComponentOptions -> IO HscEnvEq
99+
createSession (ComponentOptions theOpts _) = do
100+
libdir <- getLibdir
101+
102+
cacheDir <- getCacheDir theOpts
103+
104+
env <- runGhc (Just libdir) $ do
105+
dflags <- getSessionDynFlags
106+
(dflags', _targets) <- addCmdOpts theOpts dflags
107+
_ <- setSessionDynFlags $
108+
-- disabled, generated directly by ghcide instead
109+
flip gopt_unset Opt_WriteInterface $
110+
-- disabled, generated directly by ghcide instead
111+
-- also, it can confuse the interface stale check
112+
dontWriteHieFiles $
113+
setHiDir cacheDir $
114+
setDefaultHieDir cacheDir $
115+
setIgnoreInterfacePragmas $
116+
setLinkerOptions $
117+
disableOptimisation dflags'
118+
getSession
119+
initDynLinker env
120+
newHscEnvEq env
121+
122+
-- Set the GHC libdir to the nix libdir if it's present.
123+
getLibdir :: IO FilePath
124+
getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"
125+
126+
-- we don't want to generate object code so we compile to bytecode
127+
-- (HscInterpreted) which implies LinkInMemory
128+
-- HscInterpreted
129+
setLinkerOptions :: DynFlags -> DynFlags
130+
setLinkerOptions df = df {
131+
ghcLink = LinkInMemory
132+
, hscTarget = HscNothing
133+
, ghcMode = CompManager
134+
}
135+
136+
setIgnoreInterfacePragmas :: DynFlags -> DynFlags
137+
setIgnoreInterfacePragmas df =
138+
gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges
139+
140+
disableOptimisation :: DynFlags -> DynFlags
141+
disableOptimisation df = updOptLevel 0 df
142+
143+
setHiDir :: FilePath -> DynFlags -> DynFlags
144+
setHiDir f d =
145+
-- override user settings to avoid conflicts leading to recompilation
146+
d { hiDir = Just f}
147+
148+
getCacheDir :: [String] -> IO FilePath
149+
getCacheDir opts = IO.getXdgDirectory IO.XdgCache (cacheDir </> opts_hash)
150+
where
151+
-- Create a unique folder per set of different GHC options, assuming that each different set of
152+
-- GHC options will create incompatible interface files.
153+
opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init (map B.pack opts)

‎ghcide.cabal

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -169,6 +169,7 @@ executable ghcide
169169
main-is: Main.hs
170170
build-depends:
171171
hslogger,
172+
aeson,
172173
base == 4.*,
173174
binary,
174175
base16-bytestring >=0.1.1 && <0.2,
@@ -185,6 +186,7 @@ executable ghcide
185186
gitrev,
186187
hashable,
187188
haskell-lsp,
189+
haskell-lsp-types,
188190
hie-bios >= 0.4.0 && < 0.5,
189191
ghcide,
190192
optparse-applicative,
@@ -194,12 +196,22 @@ executable ghcide
194196
other-modules:
195197
Arguments
196198
Paths_ghcide
199+
Rules
197200
RuleTypes
198201

199202
default-extensions:
203+
BangPatterns
204+
DeriveFunctor
200205
DeriveGeneric
206+
GeneralizedNewtypeDeriving
207+
LambdaCase
208+
NamedFieldPuns
209+
OverloadedStrings
201210
RecordWildCards
211+
ScopedTypeVariables
212+
StandaloneDeriving
202213
TupleSections
214+
TypeApplications
203215
ViewPatterns
204216

205217
test-suite ghcide-tests

‎src/Development/IDE/Core/Service.hs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -61,6 +61,7 @@ initialise caps mainRule getLspId toDiags logger debouncer options vfs =
6161
logger
6262
debouncer
6363
(optShakeProfiling options)
64+
(optTesting options)
6465
(optReportProgress options)
6566
shakeOptions
6667
{ shakeThreads = optThreads options

0 commit comments

Comments
 (0)