Skip to content
This repository was archived by the owner on Oct 7, 2020. It is now read-only.

Commit 9607141

Browse files
alanzalanz
authored
Merge pull request #1215 from alanz/hare-hie-plugin-api
HaRe hie plugin api
2 parents 9ac8e76 + bf612fc commit 9607141

29 files changed

+472
-220
lines changed

‎app/MainHie.hs

Lines changed: 5 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,6 @@ module Main where
55
import Control.Monad
66
import Data.Monoid ((<>))
77
import Data.Version (showVersion)
8-
import qualified GhcMod.Types as GM
98
import Haskell.Ide.Engine.MonadFunctions
109
import Haskell.Ide.Engine.MonadTypes
1110
import Haskell.Ide.Engine.Options
@@ -121,13 +120,12 @@ run opts = do
121120
d <- getCurrentDirectory
122121
logm $ "Current directory:" ++ d
123122

124-
let vomitOptions = GM.defaultOptions { GM.optOutput = oo { GM.ooptLogLevel = GM.GmVomit}}
125-
oo = GM.optOutput GM.defaultOptions
126-
let defaultOpts = if optGhcModVomit opts then vomitOptions else GM.defaultOptions
123+
let vomitOptions = defaultOptions { boLogging = BlVomit}
124+
let defaultOpts = if optGhcModVomit opts then vomitOptions else defaultOptions
127125
-- Running HIE on projects with -Werror breaks most of the features since all warnings
128126
-- will be treated with the same severity of type errors. In order to offer a more useful
129127
-- experience, we make sure warnings are always reported as warnings by setting -Wwarn
130-
ghcModOptions = defaultOpts { GM.optGhcUserOptions = ["-Wwarn"] }
128+
biosOptions = defaultOpts { boGhcUserOptions = ["-Wwarn"] }
131129

132130
when (optGhcModVomit opts) $
133131
logm "Enabling --vomit for ghc-mod. Output will be on stderr"
@@ -139,8 +137,8 @@ run opts = do
139137

140138
-- launch the dispatcher.
141139
if optJson opts then do
142-
scheduler <- newScheduler plugins' ghcModOptions
140+
scheduler <- newScheduler plugins' biosOptions
143141
jsonStdioTransport scheduler
144142
else do
145-
scheduler <- newScheduler plugins' ghcModOptions
143+
scheduler <- newScheduler plugins' biosOptions
146144
lspStdioTransport scheduler origDir plugins' (optCaptureFile opts)

‎cabal.project

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -8,5 +8,6 @@ packages:
88
./submodules/floskell
99
./submodules/ghc-mod/
1010
./submodules/ghc-mod/core/
11+
./submodules/ghc-mod/ghc-project-types
1112

1213
tests: true

‎hie-plugin-api/Haskell/Ide/Engine/Ghc.hs

Lines changed: 238 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,238 @@
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE DeriveGeneric #-}
3+
{-# LANGUAGE FlexibleContexts #-}
4+
{-# LANGUAGE OverloadedStrings #-}
5+
{-# LANGUAGE ScopedTypeVariables #-}
6+
{-# LANGUAGE TupleSections #-}
7+
{-# LANGUAGE TypeFamilies #-}
8+
-- | This module provides the interface to GHC, mainly for loading
9+
-- modules while updating the module cache.
10+
11+
module Haskell.Ide.Engine.Ghc
12+
(
13+
setTypecheckedModule
14+
, Diagnostics
15+
, AdditionalErrs
16+
, cabalModuleGraphs
17+
, makeRevRedirMapFunc
18+
) where
19+
20+
import Bag
21+
import Control.Monad.IO.Class
22+
import Data.IORef
23+
import qualified Data.Map.Strict as Map
24+
import qualified Data.Set as Set
25+
import qualified Data.Text as T
26+
import ErrUtils
27+
import qualified GhcMod.DynFlags as GM
28+
import qualified GhcMod.Error as GM
29+
import qualified GhcMod.Gap as GM
30+
import qualified GhcMod.ModuleLoader as GM
31+
import qualified GhcMod.Monad as GM
32+
import Data.Monoid ((<>))
33+
import qualified GhcMod.Target as GM
34+
import qualified GhcMod.Types as GM
35+
import qualified GhcMod.Utils as GM
36+
import Haskell.Ide.Engine.MonadFunctions
37+
import Haskell.Ide.Engine.MonadTypes
38+
import Haskell.Ide.Engine.PluginUtils
39+
import System.FilePath
40+
41+
import DynFlags
42+
import GHC
43+
import IOEnv as G
44+
import HscTypes
45+
import Outputable (renderWithStyle)
46+
47+
-- ---------------------------------------------------------------------
48+
49+
type Diagnostics = Map.Map Uri (Set.Set Diagnostic)
50+
type AdditionalErrs = [T.Text]
51+
52+
-- ---------------------------------------------------------------------
53+
54+
lspSev :: Severity -> DiagnosticSeverity
55+
lspSev SevWarning = DsWarning
56+
lspSev SevError = DsError
57+
lspSev SevFatal = DsError
58+
lspSev SevInfo = DsInfo
59+
lspSev _ = DsInfo
60+
61+
-- ---------------------------------------------------------------------
62+
-- type LogAction = DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
63+
logDiag :: (FilePath -> FilePath) -> IORef AdditionalErrs -> IORef Diagnostics -> LogAction
64+
logDiag rfm eref dref df _reason sev spn style msg = do
65+
eloc <- srcSpan2Loc rfm spn
66+
let msgTxt = T.pack $ renderWithStyle df msg style
67+
case eloc of
68+
Right (Location uri range) -> do
69+
let update = Map.insertWith Set.union uri l
70+
where l = Set.singleton diag
71+
diag = Diagnostic range (Just $ lspSev sev) Nothing (Just "ghcmod") msgTxt Nothing
72+
modifyIORef' dref update
73+
Left _ -> do
74+
modifyIORef' eref (msgTxt:)
75+
return ()
76+
77+
-- ---------------------------------------------------------------------
78+
79+
-- unhelpfulSrcSpanErr :: T.Text -> IdeError
80+
-- unhelpfulSrcSpanErr err =
81+
-- IdeError PluginError
82+
-- ("Unhelpful SrcSpan" <> ": \"" <> err <> "\"")
83+
-- Null
84+
85+
-- ---------------------------------------------------------------------
86+
87+
srcErrToDiag :: MonadIO m
88+
=> DynFlags
89+
-> (FilePath -> FilePath)
90+
-> SourceError -> m (Diagnostics, AdditionalErrs)
91+
srcErrToDiag df rfm se = do
92+
debugm "in srcErrToDiag"
93+
let errMsgs = bagToList $ srcErrorMessages se
94+
processMsg err = do
95+
let sev = Just DsError
96+
unqual = errMsgContext err
97+
st = GM.mkErrStyle' df unqual
98+
msgTxt = T.pack $ renderWithStyle df (pprLocErrMsg err) st
99+
eloc <- srcSpan2Loc rfm $ errMsgSpan err
100+
case eloc of
101+
Right (Location uri range) ->
102+
return $ Right (uri, Diagnostic range sev Nothing (Just "ghcmod") msgTxt Nothing)
103+
Left _ -> return $ Left msgTxt
104+
processMsgs [] = return (Map.empty,[])
105+
processMsgs (x:xs) = do
106+
res <- processMsg x
107+
(m,es) <- processMsgs xs
108+
case res of
109+
Right (uri, diag) ->
110+
return (Map.insertWith Set.union uri (Set.singleton diag) m, es)
111+
Left e -> return (m, e:es)
112+
processMsgs errMsgs
113+
114+
-- ---------------------------------------------------------------------
115+
116+
myWrapper :: GM.IOish m
117+
=> (FilePath -> FilePath)
118+
-> GM.GmlT m ()
119+
-> GM.GmlT m (Diagnostics, AdditionalErrs)
120+
myWrapper rfm action = do
121+
env <- getSession
122+
diagRef <- liftIO $ newIORef Map.empty
123+
errRef <- liftIO $ newIORef []
124+
let setLogger df = df { log_action = logDiag rfm errRef diagRef }
125+
setDeferTypedHoles = setGeneralFlag' Opt_DeferTypedHoles
126+
ghcErrRes msg = (Map.empty, [T.pack msg])
127+
handlers = errorHandlers ghcErrRes (srcErrToDiag (hsc_dflags env) rfm )
128+
action' = do
129+
GM.withDynFlags (setLogger . setDeferTypedHoles) action
130+
diags <- liftIO $ readIORef diagRef
131+
errs <- liftIO $ readIORef errRef
132+
return (diags,errs)
133+
GM.gcatches action' handlers
134+
135+
-- ---------------------------------------------------------------------
136+
137+
errorHandlers :: (Monad m) => (String -> a) -> (SourceError -> m a) -> [GM.GHandler m a]
138+
errorHandlers ghcErrRes renderSourceError = handlers
139+
where
140+
-- ghc throws GhcException, SourceError, GhcApiError and
141+
-- IOEnvFailure. ghc-mod-core throws GhcModError.
142+
handlers =
143+
[ GM.GHandler $ \(ex :: GM.GhcModError) ->
144+
return $ ghcErrRes (show ex)
145+
, GM.GHandler $ \(ex :: IOEnvFailure) ->
146+
return $ ghcErrRes (show ex)
147+
, GM.GHandler $ \(ex :: GhcApiError) ->
148+
return $ ghcErrRes (show ex)
149+
, GM.GHandler $ \(ex :: SourceError) ->
150+
renderSourceError ex
151+
, GM.GHandler $ \(ex :: GhcException) ->
152+
return $ ghcErrRes $ GM.renderGm $ GM.ghcExceptionDoc ex
153+
, GM.GHandler $ \(ex :: IOError) ->
154+
return $ ghcErrRes (show ex)
155+
-- , GM.GHandler $ \(ex :: GM.SomeException) ->
156+
-- return $ ghcErrRes (show ex)
157+
]
158+
159+
-- ---------------------------------------------------------------------
160+
161+
setTypecheckedModule :: Uri -> IdeGhcM (IdeResult (Diagnostics, AdditionalErrs))
162+
setTypecheckedModule uri =
163+
pluginGetFile "setTypecheckedModule: " uri $ \fp -> do
164+
fileMap <- GM.getMMappedFiles
165+
debugm $ "setTypecheckedModule: file mapping state is: " ++ show fileMap
166+
rfm <- GM.mkRevRedirMapFunc
167+
let
168+
ghcErrRes msg = ((Map.empty, [T.pack msg]),Nothing,Nothing)
169+
progTitle = "Typechecking " <> T.pack (takeFileName fp)
170+
debugm "setTypecheckedModule: before ghc-mod"
171+
-- TODO:AZ: loading this one module may/should trigger loads of any
172+
-- other modules which currently have a VFS entry. Need to make
173+
-- sure that their diagnostics are reported, and their module
174+
-- cache entries are updated.
175+
-- TODO: Are there any hooks we can use to report back on the progress?
176+
((diags', errs), mtm, mpm) <- withIndefiniteProgress progTitle NotCancellable $ GM.gcatches
177+
(GM.getModulesGhc' (myWrapper rfm) fp)
178+
(errorHandlers ghcErrRes (return . ghcErrRes . show))
179+
debugm "setTypecheckedModule: after ghc-mod"
180+
181+
canonUri <- canonicalizeUri uri
182+
let diags = Map.insertWith Set.union canonUri Set.empty diags'
183+
diags2 <- case (mpm,mtm) of
184+
(Just pm, Nothing) -> do
185+
debugm $ "setTypecheckedModule: Did get parsed module for: " ++ show fp
186+
cacheModule fp (Left pm)
187+
debugm "setTypecheckedModule: done"
188+
return diags
189+
190+
(_, Just tm) -> do
191+
debugm $ "setTypecheckedModule: Did get typechecked module for: " ++ show fp
192+
sess <- fmap GM.gmgsSession . GM.gmGhcSession <$> GM.gmsGet
193+
194+
-- set the session before we cache the module, so that deferred
195+
-- responses triggered by cacheModule can access it
196+
modifyMTS (\s -> s {ghcSession = sess})
197+
cacheModule fp (Right tm)
198+
debugm "setTypecheckedModule: done"
199+
return diags
200+
201+
_ -> do
202+
debugm $ "setTypecheckedModule: Didn't get typechecked or parsed module for: " ++ show fp
203+
debugm $ "setTypecheckedModule: errs: " ++ show errs
204+
205+
failModule fp
206+
207+
let sev = Just DsError
208+
range = Range (Position 0 0) (Position 1 0)
209+
msgTxt = T.unlines errs
210+
let d = Diagnostic range sev Nothing (Just "ghcmod") msgTxt Nothing
211+
return $ Map.insertWith Set.union canonUri (Set.singleton d) diags
212+
213+
return $ IdeResultOk (diags2,errs)
214+
215+
-- ---------------------------------------------------------------------
216+
217+
cabalModuleGraphs :: IdeGhcM [GM.GmModuleGraph]
218+
cabalModuleGraphs = doCabalModuleGraphs
219+
where
220+
doCabalModuleGraphs :: (GM.IOish m) => GM.GhcModT m [GM.GmModuleGraph]
221+
doCabalModuleGraphs = do
222+
crdl <- GM.cradle
223+
case GM.cradleCabalFile crdl of
224+
Just _ -> do
225+
mcs <- GM.cabalResolvedComponents
226+
let graph = map GM.gmcHomeModuleGraph $ Map.elems mcs
227+
return graph
228+
Nothing -> return []
229+
230+
-- ---------------------------------------------------------------------
231+
232+
makeRevRedirMapFunc :: IdeGhcM (FilePath -> FilePath)
233+
makeRevRedirMapFunc = make
234+
where
235+
make :: (GM.IOish m) => GM.GhcModT m (FilePath -> FilePath)
236+
make = GM.mkRevRedirMapFunc
237+
238+
-- ---------------------------------------------------------------------

‎hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -114,7 +114,8 @@ withCachedInfo fp def callback = deferIfNotCached fp go
114114
-- If you need custom data, see also 'ifCachedModuleAndData'.
115115
-- If you are in IdeDeferM and would like to wait until a cached module is available,
116116
-- see also 'withCachedModule'.
117-
ifCachedModule :: (HasGhcModuleCache m, GM.MonadIO m, CacheableModule b) => FilePath -> a -> (b -> CachedInfo -> m a) -> m a
117+
ifCachedModule :: (HasGhcModuleCache m, MonadIO m, CacheableModule b)
118+
=> FilePath -> a -> (b -> CachedInfo -> m a) -> m a
118119
ifCachedModule fp def callback = do
119120
muc <- getUriCache fp
120121
let x = do
@@ -177,7 +178,7 @@ withCachedModuleAndData fp def callback = deferIfNotCached fp go
177178
go (UriCacheSuccess (UriCache _ _ Nothing _)) = wrap (Defer fp go)
178179
go UriCacheFailed = return def
179180

180-
getUriCache :: (HasGhcModuleCache m, GM.MonadIO m) => FilePath -> m (Maybe UriCacheResult)
181+
getUriCache :: (HasGhcModuleCache m, MonadIO m) => FilePath -> m (Maybe UriCacheResult)
181182
getUriCache fp = do
182183
uri' <- liftIO $ canonicalizePath fp
183184
fmap (Map.lookup uri' . uriCaches) getModuleCache
@@ -211,7 +212,7 @@ lookupCachedData fp tm info dat = do
211212

212213
-- | Saves a module to the cache and executes any deferred
213214
-- responses waiting on that module.
214-
cacheModule :: FilePath -> (Either GHC.ParsedModule GHC.TypecheckedModule) -> IdeGhcM ()
215+
cacheModule :: FilePath -> Either GHC.ParsedModule GHC.TypecheckedModule -> IdeGhcM ()
215216
cacheModule uri modul = do
216217
uri' <- liftIO $ canonicalizePath uri
217218
rfm <- GM.mkRevRedirMapFunc

‎hie-plugin-api/Haskell/Ide/Engine/PluginApi.hs

Lines changed: 71 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,71 @@
1+
-- | This module provides an API that software intented to be
2+
-- integrated into HIE can use, so that they can make use of the
3+
-- shared BIOS features.
4+
5+
{-
6+
-- Stuff used in HaRe currently
7+
Options(..)
8+
defaultOptions
9+
GmModuleGraph(..)
10+
ModulePath(..)
11+
GmComponent(..)
12+
GmComponentType(..)
13+
14+
CachedInfo(..)
15+
HasGhcModuleCache(..)
16+
IdeGhcM
17+
18+
cabalModuleGraphs
19+
filePathToUri
20+
makeRevRedirMapFunc
21+
22+
MonadIO(..)
23+
ifCachedModule
24+
runIdeGhcMBare
25+
setTypecheckedModule
26+
-}
27+
28+
29+
module Haskell.Ide.Engine.PluginApi
30+
(
31+
-- ** Re-exported from ghc-mod via ghc-project-types
32+
GP.GmModuleGraph(..)
33+
, GP.ModulePath(..)
34+
, GP.GmComponent(..)
35+
, GP.GmComponentType(..)
36+
37+
-- * IDE monads
38+
, HIE.IdeState(..)
39+
, HIE.IdeGhcM
40+
, HIE.runIdeGhcM
41+
, HIE.runIdeGhcMBare
42+
, HIE.IdeM
43+
, HIE.runIdeM
44+
, HIE.IdeDeferM
45+
, HIE.MonadIde
46+
, HIE.iterT
47+
, HIE.LiftsToGhc(..)
48+
, HIE.HasGhcModuleCache(..)
49+
, HIE.cabalModuleGraphs
50+
, HIE.makeRevRedirMapFunc
51+
52+
-- * Using the HIE module cache etc
53+
, HIE.setTypecheckedModule
54+
, HIE.Diagnostics
55+
, HIE.AdditionalErrs
56+
, LSP.filePathToUri
57+
, HIE.ifCachedModule
58+
, HIE.CachedInfo(..)
59+
60+
-- * used for tests in HaRe
61+
, HIE.BiosLogLevel(..)
62+
, HIE.BiosOptions(..)
63+
, HIE.defaultOptions
64+
) where
65+
66+
import qualified GhcProject.Types as GP
67+
import qualified Haskell.Ide.Engine.Ghc as HIE
68+
import qualified Haskell.Ide.Engine.GhcModuleCache as HIE (CachedInfo(..),HasGhcModuleCache(..))
69+
import qualified Haskell.Ide.Engine.ModuleCache as HIE (ifCachedModule)
70+
import qualified Haskell.Ide.Engine.PluginsIdeMonads as HIE
71+
import qualified Language.Haskell.LSP.Types as LSP ( filePathToUri )

‎hie-plugin-api/Haskell/Ide/Engine/PluginUtils.hs

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -92,6 +92,8 @@ srcSpan2Range :: SrcSpan -> Either T.Text Range
9292
srcSpan2Range spn =
9393
realSrcSpan2Range <$> getRealSrcSpan spn
9494

95+
96+
9597
reverseMapFile :: MonadIO m => (FilePath -> FilePath) -> FilePath -> m FilePath
9698
reverseMapFile rfm fp = do
9799
fp' <- liftIO $ canonicalizePath fp
@@ -288,4 +290,4 @@ rangeLinesFromVfs (VirtualFile _ yitext) (Range (Position lf _cf) (Position lt _
288290
where
289291
(_ ,s1) = Yi.splitAtLine lf yitext
290292
(s2, _) = Yi.splitAtLine (lt - lf) s1
291-
r = Yi.toText s2
293+
r = Yi.toText s2

0 commit comments

Comments
 (0)