Skip to content

Commit 8963b2b

Browse files
wz1000wz1000
committed
Add support for the multi unit argument syntax introduced in GHC 9.4: https://downloads.haskell.org/ghc/9.4.4/docs/users_guide/using.html#multiple-home-units
We now support arguments of the form ``` -unit @unitA -unit @unitb ``` where the response files `unitA` and `unitB` contain the actual list of arguments for that unit: ``` -this-unit-id a-0.1.0.0 -i -isrc A1 A2 ``` Also refactor the session loader and simplify it. Also adds error messages on GHC 9.4 if the units are not closed (#3422).
1 parent 35621b8 commit 8963b2b

File tree

14 files changed

+324
-118
lines changed

14 files changed

+324
-118
lines changed

‎ghcide/ghcide.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -164,6 +164,7 @@ library
164164
Development.IDE.Core.UseStale
165165
Development.IDE.GHC.Compat
166166
Development.IDE.GHC.Compat.Core
167+
Development.IDE.GHC.Compat.CmdLine
167168
Development.IDE.GHC.Compat.Env
168169
Development.IDE.GHC.Compat.Iface
169170
Development.IDE.GHC.Compat.Logger

‎ghcide/session-loader/Development/IDE/Session.hs

Lines changed: 173 additions & 115 deletions
Large diffs are not rendered by default.

‎ghcide/src/Development/IDE/GHC/Compat/CmdLine.hs

Lines changed: 48 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,48 @@
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE RankNTypes #-}
3+
4+
-- | Compat module Interface file relevant code.
5+
module Development.IDE.GHC.Compat.CmdLine (
6+
processCmdLineP
7+
, CmdLineP (..)
8+
, getCmdLineState
9+
, putCmdLineState
10+
, Flag(..)
11+
, OptKind(..)
12+
, EwM
13+
, defFlag
14+
, liftEwM
15+
) where
16+
17+
#if MIN_VERSION_ghc(9,3,0)
18+
import GHC.Driver.Session (processCmdLineP, CmdLineP (..), getCmdLineState, putCmdLineState)
19+
import GHC.Driver.CmdLine
20+
#else
21+
22+
#if MIN_VERSION_ghc(9,0,0)
23+
import GHC.Driver.CmdLine
24+
#else
25+
import CmdLineParser
26+
#endif
27+
28+
import Control.Monad.IO.Class
29+
import Control.Monad.Trans.State
30+
import GHC (Located, mkGeneralLocated)
31+
import GHC.ResponseFile
32+
import Control.Exception
33+
#endif
34+
35+
#if !MIN_VERSION_ghc(9,3,0)
36+
-- | A helper to parse a set of flags from a list of command-line arguments, handling
37+
-- response files.
38+
processCmdLineP
39+
:: forall s m. MonadIO m
40+
=> [Flag (CmdLineP s)] -- ^ valid flags to match against
41+
-> s -- ^ current state
42+
-> [Located String] -- ^ arguments to parse
43+
-> m (([Located String], [Err], [Warn]), s)
44+
-- ^ (leftovers, errors, warnings)
45+
processCmdLineP activeFlags s0 args =
46+
pure $ runCmdLine (processArgs activeFlags args) s0
47+
48+
#endif

‎ghcide/src/Development/IDE/GHC/Compat/Env.hs

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -51,6 +51,7 @@ module Development.IDE.GHC.Compat.Env (
5151
Backend,
5252
setBackend,
5353
Development.IDE.GHC.Compat.Env.platformDefaultBackend,
54+
workingDirectory
5455
) where
5556

5657
import GHC (setInteractiveDynFlags)
@@ -109,6 +110,11 @@ hsc_EPS :: HscEnv -> UnitEnv
109110
hsc_EPS = hsc_unit_env
110111
#endif
111112

113+
#if !MIN_VERSION_ghc(9,3,0)
114+
workingDirectory :: a -> Maybe b
115+
workingDirectory _ = Nothing
116+
#endif
117+
112118
#if !MIN_VERSION_ghc(9,2,0)
113119
type UnitEnv = ()
114120
newtype Logger = Logger { log_action :: LogAction }

‎ghcide/src/Development/IDE/GHC/Compat/Units.hs

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -5,9 +5,7 @@
55
module Development.IDE.GHC.Compat.Units (
66
-- * UnitState
77
UnitState,
8-
#if MIN_VERSION_ghc(9,3,0)
98
initUnits,
10-
#endif
119
oldInitUnits,
1210
unitState,
1311
getUnitName,
@@ -180,8 +178,12 @@ initUnits unitDflags env = do
180178
, ue_eps = ue_eps (hsc_unit_env env)
181179
}
182180
pure $ hscSetFlags dflags1 $ hscSetUnitEnv unit_env env
181+
#else
182+
initUnits :: [DynFlags] -> HscEnv -> IO HscEnv
183+
initUnits _df env = pure env -- Can't do anything here, oldInitUnits should already be called
183184
#endif
184185

186+
185187
-- | oldInitUnits only needs to modify DynFlags for GHC <9.2
186188
-- For GHC >= 9.2, we need to set the hsc_unit_env also, that is
187189
-- done later by initUnits

‎ghcide/test/data/multi-unit/a-1.0.0-inplace

Lines changed: 18 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,18 @@
1+
-this-package-name
2+
a
3+
-working-dir
4+
a
5+
-fbuilding-cabal-package
6+
-O0
7+
-i.
8+
-this-unit-id
9+
a-1.0.0-inplace
10+
-hide-all-packages
11+
-Wmissing-home-modules
12+
-no-user-package-db
13+
-package
14+
base
15+
-package
16+
text
17+
-XHaskell98
18+
A

‎ghcide/test/data/multi-unit/a/A.hs

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
module A(foo) where
2+
import Data.Text
3+
foo = ()

‎ghcide/test/data/multi-unit/b-1.0.0-inplace

Lines changed: 19 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,19 @@
1+
-this-package-name
2+
b
3+
-working-dir
4+
b
5+
-fbuilding-cabal-package
6+
-O0
7+
-i
8+
-i.
9+
-this-unit-id
10+
b-1.0.0-inplace
11+
-hide-all-packages
12+
-Wmissing-home-modules
13+
-no-user-package-db
14+
-package-id
15+
a-1.0.0-inplace
16+
-package
17+
base
18+
-XHaskell98
19+
B

‎ghcide/test/data/multi-unit/b/B.hs

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
module B(module B) where
2+
import A
3+
qux = foo

‎ghcide/test/data/multi-unit/c-1.0.0-inplace

Lines changed: 19 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,19 @@
1+
-this-package-name
2+
c
3+
-working-dir
4+
c
5+
-fbuilding-cabal-package
6+
-O0
7+
-i
8+
-i.
9+
-this-unit-id
10+
c-1.0.0-inplace
11+
-hide-all-packages
12+
-Wmissing-home-modules
13+
-no-user-package-db
14+
-package-id
15+
a-1.0.0-inplace
16+
-package
17+
base
18+
-XHaskell98
19+
C

‎ghcide/test/data/multi-unit/c/C.hs

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
module C(module C) where
2+
import A
3+
cux = foo

‎ghcide/test/data/multi-unit/cabal.project

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,2 @@
1+
packages: a b c
2+
multi-repl: True

‎ghcide/test/data/multi-unit/hie.yaml

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
cradle:
2+
direct:
3+
arguments: ["-unit" ,"@a-1.0.0-inplace"
4+
,"-unit" ,"@b-1.0.0-inplace"
5+
,"-unit" ,"@c-1.0.0-inplace"
6+
]

‎ghcide/test/exe/Main.hs

Lines changed: 19 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2507,7 +2507,7 @@ cradleTests = testGroup "cradle"
25072507
[testGroup "dependencies" [sessionDepsArePickedUp]
25082508
,testGroup "ignore-fatal" [ignoreFatalWarning]
25092509
,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle]
2510-
,testGroup "multi" [simpleMultiTest, simpleMultiTest2, simpleMultiTest3, simpleMultiDefTest]
2510+
,testGroup "multi" [simpleMultiTest, simpleMultiTest2, simpleMultiTest3, simpleMultiDefTest, simpleMultiUnitTest]
25112511
,testGroup "sub-directory" [simpleSubDirectoryTest]
25122512
]
25132513

@@ -2638,6 +2638,24 @@ simpleMultiTest = testCase "simple-multi-test" $ withLongTimeout $ runWithExtraF
26382638
checkDefs locs (pure [fooL])
26392639
expectNoMoreDiagnostics 0.5
26402640

2641+
-- Test support for loading multiple components as -unit flags as
2642+
-- implemented in GHC 9.4
2643+
simpleMultiUnitTest :: TestTree
2644+
simpleMultiUnitTest = testCase "simple-multi-unit-test" $ withLongTimeout $ runWithExtraFiles "multi-unit" $ \dir -> do
2645+
let aPath = dir </> "a/A.hs"
2646+
bPath = dir </> "b/B.hs"
2647+
cPath = dir </> "c/C.hs"
2648+
bdoc <- openDoc bPath "haskell"
2649+
WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc
2650+
TextDocumentIdentifier auri <- openDoc aPath "haskell"
2651+
skipManyTill anyMessage $ isReferenceReady aPath
2652+
cdoc <- openDoc cPath "haskell"
2653+
WaitForIdeRuleResult {} <- waitForAction "TypeCheck" cdoc
2654+
locs <- getDefinitions cdoc (Position 2 7)
2655+
let fooL = mkL auri 2 0 2 3
2656+
checkDefs locs (pure [fooL])
2657+
expectNoMoreDiagnostics 0.5
2658+
26412659
-- Like simpleMultiTest but open the files in the other order
26422660
simpleMultiTest2 :: TestTree
26432661
simpleMultiTest2 = testCase "simple-multi-test2" $ runWithExtraFiles "multi" $ \dir -> do

0 commit comments

Comments
 (0)