Skip to content

Commit 7e2d3bc

Browse files
pepeiborrapepeiborra
committed
Bugfixes, formatting, temporary
1 parent d37d436 commit 7e2d3bc

File tree

2 files changed

+77
-86
lines changed

2 files changed

+77
-86
lines changed

‎haskell-language-server.cabal‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -69,7 +69,6 @@ library
6969
, deepseq
7070
, Diff
7171
, directory
72-
, exceptions
7372
, extra
7473
, filepath
7574
, floskell == 0.10.*
@@ -87,6 +86,7 @@ library
8786
, regex-tdfa >= 1.3.1.0
8887
, shake >= 0.17.5
8988
, stylish-haskell == 0.11.*
89+
, temporary
9090
, text
9191
, time
9292
, transformers

‎src/Ide/Plugin/Eval.hs‎

Lines changed: 76 additions & 85 deletions
Original file line numberDiff line numberDiff line change
@@ -22,7 +22,6 @@
2222
module Ide.Plugin.Eval where
2323

2424
import Control.Monad (void)
25-
import Control.Monad.Catch (MonadMask, bracket)
2625
import Control.Monad.IO.Class (MonadIO (liftIO))
2726
import Control.Monad.Trans.Class (MonadTrans (lift))
2827
import Control.Monad.Trans.Except (ExceptT (..), runExceptT,
@@ -45,8 +44,7 @@ import Development.IDE.Types.Location (toNormalizedFilePath',
4544
uriToFilePath')
4645
import DynamicLoading (initializePlugins)
4746
import DynFlags (targetPlatform)
48-
import GHC (DynFlags, ExecResult (..),
49-
GeneralFlag (Opt_IgnoreHpcChanges, Opt_IgnoreOptimChanges, Opt_ImplicitImportQualified),
47+
import GHC (DynFlags, ExecResult (..), GeneralFlag (Opt_IgnoreHpcChanges, Opt_IgnoreOptimChanges, Opt_ImplicitImportQualified),
5048
GhcLink (LinkInMemory),
5149
GhcMode (CompManager),
5250
HscTarget (HscInterpreted),
@@ -80,9 +78,9 @@ import Language.Haskell.LSP.Core (LspFuncs (getVirtualFileFunc))
8078
import Language.Haskell.LSP.Types
8179
import Language.Haskell.LSP.VFS (virtualFileText)
8280
import PrelNames (pRELUDE)
83-
import System.IO (Handle, IOMode (WriteMode),
84-
hClose, openFile)
85-
import System.IO.Extra (newTempFile)
81+
import System.FilePath
82+
import System.IO (hClose)
83+
import System.IO.Temp
8684

8785
descriptor :: PluginId -> PluginDescriptor
8886
descriptor plId =
@@ -97,10 +95,10 @@ extractMatches = goSearch 0 . maybe [] T.lines
9795
where
9896
checkMatch = T.stripPrefix "-- >>> "
9997
looksLikeSplice l
100-
| Just l' <- T.stripPrefix "--" l
101-
= not (" >>>" `T.isPrefixOf` l')
102-
| otherwise
103-
= False
98+
| Just l' <- T.stripPrefix "--" l =
99+
not (" >>>" `T.isPrefixOf` l')
100+
| otherwise =
101+
False
104102

105103
goSearch _ [] = []
106104
goSearch line (l : ll)
@@ -109,17 +107,17 @@ extractMatches = goSearch 0 . maybe [] T.lines
109107
| otherwise =
110108
goSearch (line + 1) ll
111109

112-
goAcc line acc [] = [(reverse acc,Range p p)] where p = Position line 0
113-
goAcc line acc (l:ll)
110+
goAcc line acc [] = [(reverse acc, Range p p)] where p = Position line 0
111+
goAcc line acc (l : ll)
114112
| Just match <- checkMatch l =
115113
goAcc (line + 1) ([(match, line)] <> acc) ll
116114
| otherwise =
117-
(reverse acc,r) : goSearch (line + 1) ll
115+
(reverse acc, r) : goSearch (line + 1) ll
118116
where
119117
r = Range p p'
120118
p = Position line 0
121119
p' = Position (line + spliceLength) 0
122-
spliceLength = length (takeWhile looksLikeSplice (l:ll))
120+
spliceLength = length (takeWhile looksLikeSplice (l : ll))
123121

124122
provider :: CodeLensProvider
125123
provider lsp _state plId CodeLensParams {_textDocument} = response $ do
@@ -134,20 +132,21 @@ provider lsp _state plId CodeLensParams {_textDocument} = response $ do
134132
[ CodeLens range (Just cmd') Nothing
135133
| (m, r) <- matches,
136134
let (_, startLine) = head m
137-
(_, endLine) = last m
135+
(endLineContents, endLine) = last m
138136
range = Range start end
139137
start = Position startLine 0
140-
end = Position endLine 1000
138+
end = Position endLine (T.length endLineContents)
141139
args = EvalParams m r _textDocument,
142-
let cmd' = (cmd :: Command)
143-
{_arguments = Just (List [toJSON args])
144-
,_title = if trivial r then "Evaluate..." else "Refresh..."
140+
let cmd' =
141+
(cmd :: Command)
142+
{ _arguments = Just (List [toJSON args]),
143+
_title = if trivial r then "Evaluate..." else "Refresh..."
145144
}
146145
]
147146

148147
return $ List lenses
149148
where
150-
trivial (Range p p') = p == p'
149+
trivial (Range p p') = p == p'
151150

152151
evalCommandName :: CommandId
153152
evalCommandName = "evalCommand"
@@ -171,93 +170,98 @@ runEvalCmd lsp state EvalParams {..} = response' $ do
171170
text <- handleMaybe "contents" $ virtualFileText <$> contents
172171

173172
session <-
174-
liftIO
175-
$ runAction "runEvalCmd.ghcSession" state
176-
$ use_ GhcSessionDeps
177-
$ toNormalizedFilePath'
178-
$ fp
173+
liftIO $
174+
runAction "runEvalCmd.ghcSession" state $
175+
use_ GhcSessionDeps $
176+
toNormalizedFilePath' $
177+
fp
179178

180179
ms <-
181-
liftIO
182-
$ runAction "runEvalCmd.getModSummary" state
183-
$ use_ GetModSummary
184-
$ toNormalizedFilePath'
185-
$ fp
180+
liftIO $
181+
runAction "runEvalCmd.getModSummary" state $
182+
use_ GetModSummary $
183+
toNormalizedFilePath' $
184+
fp
186185

187186
now <- liftIO getCurrentTime
188187

189-
withTempFile $ \temp -> withTempFile $ \tempLog -> withFile tempLog WriteMode $ \hLog -> do
188+
let tmp = withSystemTempFile (takeFileName fp)
189+
190+
tmp $ \temp _h -> tmp $ \tempLog hLog -> do
191+
liftIO $ hClose _h
190192
let modName = moduleName $ ms_mod ms
191193
thisModuleTarget = Target (TargetFile fp Nothing) False (Just (textToStringBuffer text, now))
192194

193-
hscEnv' <- ExceptT $ evalGhcEnv (hscEnv session) $ do
194-
df <- getSessionDynFlags
195-
env <- getSession
196-
df <- liftIO $ setupDynFlagsForGHCiLike env df
197-
_lp <- setSessionDynFlags df
198-
199-
-- copy the package state to the interactive DynFlags
200-
idflags <- getInteractiveDynFlags
201-
df <- getSessionDynFlags
202-
setInteractiveDynFlags
203-
idflags
204-
{ pkgState = pkgState df,
205-
pkgDatabase = pkgDatabase df,
206-
packageFlags = packageFlags df
207-
}
208-
209-
-- set up a custom log action
210-
setLogAction $ \_df _wr _sev _span _style _doc ->
211-
defaultLogActionHPutStrDoc _df hLog _doc _style
212-
213-
-- load the module in the interactive environment
214-
setTargets [thisModuleTarget]
215-
loadResult <- load LoadAllTargets
216-
case loadResult of
217-
Failed -> liftIO $ do
195+
hscEnv' <- ExceptT $
196+
evalGhcEnv (hscEnv session) $ do
197+
df <- getSessionDynFlags
198+
env <- getSession
199+
df <- liftIO $ setupDynFlagsForGHCiLike env df
200+
_lp <- setSessionDynFlags df
201+
202+
-- copy the package state to the interactive DynFlags
203+
idflags <- getInteractiveDynFlags
204+
df <- getSessionDynFlags
205+
setInteractiveDynFlags
206+
idflags
207+
{ pkgState = pkgState df,
208+
pkgDatabase = pkgDatabase df,
209+
packageFlags = packageFlags df
210+
}
211+
212+
-- set up a custom log action
213+
setLogAction $ \_df _wr _sev _span _style _doc ->
214+
defaultLogActionHPutStrDoc _df hLog _doc _style
215+
216+
-- load the module in the interactive environment
217+
setTargets [thisModuleTarget]
218+
loadResult <- load LoadAllTargets
219+
case loadResult of
220+
Failed -> liftIO $ do
218221
hClose hLog
219222
Left <$> readFile tempLog
220-
Succeeded -> do
223+
Succeeded -> do
221224
setContext [IIDecl (simpleImportDecl $ moduleName pRELUDE), IIModule modName]
222225
Right <$> getSession
223226

224227
df <- liftIO $ evalGhcEnv hscEnv' getSessionDynFlags
225228
let eval (stmt, l)
226229
| isStmt df stmt = do
227-
228230
-- set up a custom interactive print function
229231
ctxt <- getContext
230232
setContext [IIDecl (simpleImportDecl $ moduleName pRELUDE)]
231233
let printFun = "let ghcideCustomShow x = Prelude.writeFile " <> show temp <> " (Prelude.show x)"
232-
interactivePrint <- execStmt printFun execOptions >>= \case
234+
interactivePrint <-
235+
execStmt printFun execOptions >>= \case
233236
ExecComplete (Right [interactivePrint]) _ -> pure interactivePrint
234237
_ -> error "internal error binding print function"
235238
modifySession $ \hsc -> hsc {hsc_IC = setInteractivePrintName (hsc_IC hsc) interactivePrint}
236239
setContext ctxt
237240

238241
let opts =
239-
execOptions
242+
execOptions
240243
{ execSourceFile = fp,
241-
execLineNumber = l
244+
execLineNumber = l
242245
}
243246
res <- execStmt stmt opts
244247
str <- case res of
245-
ExecComplete (Left err) _ -> pure $ pad $ show err
246-
ExecComplete (Right _) _ -> liftIO $ pad <$> readFile temp
247-
ExecBreak {} -> pure $ pad "breakpoints are not supported"
248+
ExecComplete (Left err) _ -> pure $ pad $ show err
249+
ExecComplete (Right _) _ -> do
250+
out <- liftIO $ pad <$> readFile temp
251+
let forceIt = length out
252+
return $! forceIt `seq` out
253+
ExecBreak {} -> pure $ pad "breakpoints are not supported"
248254

249255
let changes = [TextEdit editTarget $ T.pack str]
250256
return changes
251-
252257
| isImport df stmt = do
253-
ctxt <- getContext
254-
idecl <- parseImportDecl stmt
255-
setContext $ IIDecl idecl : ctxt
256-
return []
257-
258+
ctxt <- getContext
259+
idecl <- parseImportDecl stmt
260+
setContext $ IIDecl idecl : ctxt
261+
return []
258262
| otherwise = do
259-
void $ runDecls stmt
260-
return []
263+
void $ runDecls stmt
264+
return []
261265

262266
edits <- liftIO $ evalGhcEnv hscEnv' $ traverse (eval . first T.unpack) statements
263267

@@ -315,16 +319,3 @@ setupDynFlagsForGHCiLike env dflags = do
315319
`gopt_set` Opt_IgnoreOptimChanges
316320
`gopt_set` Opt_IgnoreHpcChanges
317321
initializePlugins env dflags4
318-
319-
320-
withTempFile :: (MonadIO m, MonadMask m) => (FilePath -> m a) -> m a
321-
withTempFile k = bracket alloc release (k . fst)
322-
where
323-
alloc = liftIO newTempFile
324-
release = liftIO . snd
325-
326-
withFile :: (MonadMask m, MonadIO m) => FilePath -> IOMode -> (Handle -> m b) -> m b
327-
withFile f mode = bracket alloc release
328-
where
329-
alloc = liftIO $ openFile f mode
330-
release = liftIO . hClose

0 commit comments

Comments
 (0)