Skip to content

Commit 7dbfb97

Browse files
alanzalanz
committed
Rebase against ghcide, in the hope of getting it to work.
Currently (for me) neither ghcide nor haskell-language-server can resolve a simple project. Assume some sort of underlying hie-bios issue, will wait.
1 parent 90aae36 commit 7dbfb97

File tree

5 files changed

+182
-106
lines changed

5 files changed

+182
-106
lines changed

‎exe/Arguments.hs‎

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -30,6 +30,7 @@ data Arguments = Arguments
3030
,argFiles :: [FilePath]
3131
,argsVersion :: Bool
3232
,argsShakeProfiling :: Maybe FilePath
33+
,argsTesting :: Bool
3334
,argsExamplePlugin :: Bool
3435
}
3536

@@ -45,12 +46,14 @@ arguments :: String -> Parser Arguments
4546
arguments exeName = Arguments
4647
<$> switch (long "lsp" <> help "Start talking to an LSP server")
4748
<*> optional (strOption $ long "cwd" <> metavar "DIR"
48-
<> help "Change to this directory")
49+
<> help "Change to this directory")
4950
<*> many (argument str (metavar "FILES/DIRS..."))
5051
<*> switch (long "version"
5152
<> help ("Show " ++ exeName ++ " and GHC versions"))
5253
<*> optional (strOption $ long "shake-profiling" <> metavar "DIR"
53-
<> help "Dump profiling reports to this directory")
54+
<> help "Dump profiling reports to this directory")
55+
<*> switch (long "test"
56+
<> help "Enable additional lsp messages used by the testsuite")
5457
<*> switch (long "example"
5558
<> help "Include the Example Plugin. For Plugin devs only")
5659

‎exe/Main.hs‎

Lines changed: 18 additions & 103 deletions
Original file line numberDiff line numberDiff line change
@@ -15,11 +15,11 @@ import Control.Concurrent.Extra
1515
import Control.Exception
1616
import Control.Monad.Extra
1717
import Control.Monad.IO.Class
18-
import qualified Crypto.Hash.SHA1 as H
19-
import Data.ByteString.Base16
20-
import qualified Data.ByteString.Char8 as B
18+
-- import qualified Crypto.Hash.SHA1 as H
19+
-- import Data.ByteString.Base16
20+
-- import qualified Data.ByteString.Char8 as B
2121
import Data.Default
22-
import Data.Functor ((<&>))
22+
-- import Data.Functor ((<&>))
2323
import qualified Data.HashSet as HashSet
2424
import Data.List.Extra
2525
import qualified Data.Map.Strict as Map
@@ -43,24 +43,26 @@ import Development.IDE.Types.Diagnostics
4343
import Development.IDE.Types.Location
4444
import Development.IDE.Types.Logger
4545
import Development.IDE.Types.Options
46-
import Development.Shake (Action, Rules, action, doesFileExist, doesDirectoryExist, need)
47-
import DynFlags
48-
import GHC hiding (def)
46+
import Development.Shake (Action, Rules, action)
47+
-- import DynFlags
48+
-- import GHC hiding (def)
4949
-- import qualified GHC.Paths
5050
import HIE.Bios
51-
import HIE.Bios.Cradle
52-
import HIE.Bios.Environment
53-
import HIE.Bios.Types
51+
import qualified Language.Haskell.LSP.Core as LSP
52+
-- import HIE.Bios.Cradle
53+
-- import HIE.Bios.Environment
54+
-- import HIE.Bios.Types
5455
import Ide.Plugin
5556
-- import Ide.PluginDescriptors
5657
import Ide.Plugin.Config
5758
-- import Ide.Plugin.Formatter
5859
import Language.Haskell.LSP.Messages
5960
import Language.Haskell.LSP.Types (LspId(IdInt))
60-
import qualified Language.Haskell.LSP.Core as LSP
61-
import Linker
61+
-- import qualified Language.Haskell.LSP.Core as LSP
62+
-- import Linker
6263
-- import Paths_haskell_language_server
6364
import RuleTypes
65+
import Rules
6466
import qualified System.Directory.Extra as IO
6567
-- import System.Environment
6668
import System.Exit
@@ -139,6 +141,7 @@ idePlugins includeExamples
139141

140142
-- ---------------------------------------------------------------------
141143
-- Prefix for the cache path
144+
{-
142145
cacheDir :: String
143146
cacheDir = "ghcide"
144147
@@ -148,7 +151,7 @@ getCacheDir opts = IO.getXdgDirectory IO.XdgCache (cacheDir </> opts_hash)
148151
-- Create a unique folder per set of different GHC options, assuming that each different set of
149152
-- GHC options will create incompatible interface files.
150153
opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init (map B.pack opts)
151-
154+
-}
152155

153156
main :: IO ()
154157
main = do
@@ -184,6 +187,7 @@ main = do
184187
let options = (defaultIdeOptions $ loadSession dir)
185188
{ optReportProgress = clientSupportsProgress caps
186189
, optShakeProfiling = argsShakeProfiling
190+
, optTesting = IdeTesting argsTesting
187191
}
188192
debouncer <- newAsyncDebouncer
189193
initialise caps (cradleRules >> mainRule >> pluginRules plugins >> action kick)
@@ -239,7 +243,7 @@ main = do
239243

240244
cradleRules :: Rules ()
241245
cradleRules = do
242-
loadGhcSessionIO
246+
loadGhcSession
243247
cradleToSession
244248

245249
expandFiles :: [FilePath] -> IO [FilePath]
@@ -267,95 +271,6 @@ showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =
267271
withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags
268272
showEvent lock e = withLock lock $ print e
269273

270-
271-
loadGhcSessionIO :: Rules ()
272-
loadGhcSessionIO =
273-
-- This rule is for caching the GHC session. E.g., even when the cabal file
274-
-- changed, if the resulting flags did not change, we would continue to use
275-
-- the existing session.
276-
defineNoFile $ \(GetHscEnv opts deps) ->
277-
liftIO $ createSession $ ComponentOptions opts deps
278-
279-
280-
getComponentOptions :: Cradle a -> IO ComponentOptions
281-
getComponentOptions cradle = do
282-
let showLine s = putStrLn ("> " ++ s)
283-
-- WARNING 'runCradle is very expensive and must be called as few times as possible
284-
cradleRes <- runCradle (cradleOptsProg cradle) showLine ""
285-
case cradleRes of
286-
CradleSuccess r -> pure r
287-
CradleFail err -> throwIO err
288-
-- TODO Rather than failing here, we should ignore any files that use this cradle.
289-
-- That will require some more changes.
290-
CradleNone -> fail "'none' cradle is not yet supported"
291-
292-
293-
createSession :: ComponentOptions -> IO HscEnvEq
294-
createSession (ComponentOptions theOpts _) = do
295-
libdir <- getLibdir
296-
297-
cacheDir <- Main.getCacheDir theOpts
298-
299-
env <- runGhc (Just libdir) $ do
300-
dflags <- getSessionDynFlags
301-
(dflags', _targets) <- addCmdOpts theOpts dflags
302-
_ <- setSessionDynFlags $
303-
-- disabled, generated directly by ghcide instead
304-
flip gopt_unset Opt_WriteInterface $
305-
-- disabled, generated directly by ghcide instead
306-
-- also, it can confuse the interface stale check
307-
dontWriteHieFiles $
308-
setHiDir cacheDir $
309-
setDefaultHieDir cacheDir $
310-
setIgnoreInterfacePragmas $
311-
setLinkerOptions $
312-
disableOptimisation dflags'
313-
getSession
314-
initDynLinker env
315-
newHscEnvEq env
316-
317-
-- we don't want to generate object code so we compile to bytecode
318-
-- (HscInterpreted) which implies LinkInMemory
319-
-- HscInterpreted
320-
setLinkerOptions :: DynFlags -> DynFlags
321-
setLinkerOptions df = df {
322-
ghcLink = LinkInMemory
323-
, hscTarget = HscNothing
324-
, ghcMode = CompManager
325-
}
326-
327-
setIgnoreInterfacePragmas :: DynFlags -> DynFlags
328-
setIgnoreInterfacePragmas df =
329-
gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges
330-
331-
disableOptimisation :: DynFlags -> DynFlags
332-
disableOptimisation df = updOptLevel 0 df
333-
334-
setHiDir :: FilePath -> DynFlags -> DynFlags
335-
setHiDir f d =
336-
-- override user settings to avoid conflicts leading to recompilation
337-
d { hiDir = Just f}
338-
339-
cradleToSession :: Rules ()
340-
cradleToSession = define $ \LoadCradle nfp -> do
341-
let f = fromNormalizedFilePath nfp
342-
343-
-- If the path points to a directory, load the implicit cradle
344-
mbYaml <- doesDirectoryExist f <&> \isDir -> if isDir then Nothing else Just f
345-
cradle <- liftIO $ maybe (loadImplicitCradle $ addTrailingPathSeparator f) loadCradle mbYaml
346-
347-
cmpOpts <- liftIO $ getComponentOptions cradle
348-
let opts = componentOptions cmpOpts
349-
deps = componentDependencies cmpOpts
350-
deps' = case mbYaml of
351-
-- For direct cradles, the hie.yaml file itself must be watched.
352-
Just yaml | isDirectCradle cradle -> yaml : deps
353-
_ -> deps
354-
existingDeps <- filterM doesFileExist deps'
355-
need existingDeps
356-
([],) . pure <$> useNoFile_ (GetHscEnv opts deps)
357-
358-
359274
loadSession :: FilePath -> Action (FilePath -> Action HscEnvEq)
360275
loadSession dir = liftIO $ do
361276
cradleLoc <- memoIO $ \v -> do

‎exe/Rules.hs‎

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

‎ghcide‎

‎haskell-language-server.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -92,6 +92,7 @@ executable haskell-language-server
9292
other-modules:
9393
Arguments
9494
Paths_haskell_language_server
95+
Rules
9596
RuleTypes
9697
autogen-modules:
9798
Paths_haskell_language_server
@@ -111,6 +112,7 @@ executable haskell-language-server
111112

112113
build-depends:
113114
base >=4.7 && <5
115+
, aeson
114116
, base16-bytestring
115117
, binary
116118
, bytestring

0 commit comments

Comments
 (0)