Skip to content

Commit f366c7b

Browse files
pepeiborrapepeiborra
committed
Eval plugin
1 parent 768fdcd commit f366c7b

File tree

3 files changed

+306
-1
lines changed

3 files changed

+306
-1
lines changed

‎exe/Main.hs

+2
Original file line numberDiff line numberDiff line change
@@ -97,6 +97,7 @@ import Development.IDE.Plugin.Completions as Completions
9797
import Development.IDE.LSP.HoverDefinition as HoverDefinition
9898

9999
-- haskell-language-server plugins
100+
import Ide.Plugin.Eval as Eval
100101
import Ide.Plugin.Example as Example
101102
import Ide.Plugin.Example2 as Example2
102103
import Ide.Plugin.GhcIde as GhcIde
@@ -143,6 +144,7 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins
143144
#if AGPL
144145
, Brittany.descriptor "brittany"
145146
#endif
147+
, Eval.descriptor "eval"
146148
]
147149
examplePlugins =
148150
[Example.descriptor "eg"

‎haskell-language-server.cabal

+5-1
Original file line numberDiff line numberDiff line change
@@ -18,7 +18,7 @@ extra-source-files:
1818

1919
flag agpl
2020
Description: Enable AGPL dependencies
21-
Default: True
21+
Default: False
2222
Manual: False
2323

2424
flag pedantic
@@ -42,6 +42,7 @@ library
4242
Ide.Logger
4343
Ide.Plugin
4444
Ide.Plugin.Config
45+
Ide.Plugin.Eval
4546
Ide.Plugin.Example
4647
Ide.Plugin.Example2
4748
Ide.Plugin.GhcIde
@@ -69,6 +70,7 @@ library
6970
, deepseq
7071
, Diff
7172
, directory
73+
, exceptions
7274
, extra
7375
, filepath
7476
, floskell == 0.10.*
@@ -84,9 +86,11 @@ library
8486
, optparse-simple
8587
, process
8688
, regex-tdfa >= 1.3.1.0
89+
, rope-utf16-splay
8790
, shake >= 0.17.5
8891
, stylish-haskell == 0.11.*
8992
, text
93+
, time
9094
, transformers
9195
, unordered-containers
9296
if os(windows)

‎src/Ide/Plugin/Eval.hs

+299
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,299 @@
1+
{-# LANGUAGE DeriveAnyClass #-}
2+
{-# LANGUAGE DeriveGeneric #-}
3+
{-# LANGUAGE DuplicateRecordFields #-}
4+
{-# LANGUAGE LambdaCase #-}
5+
{-# LANGUAGE NamedFieldPuns #-}
6+
{-# LANGUAGE OverloadedStrings #-}
7+
{-# LANGUAGE RecordWildCards #-}
8+
{-# LANGUAGE ScopedTypeVariables #-}
9+
{-# LANGUAGE TupleSections #-}
10+
11+
-- | A plugin inspired by the REPLoid feature of Dante[1] which allows
12+
-- to evaluate code in comment prompts and splice the results right below:
13+
--
14+
-- > example :: [String]
15+
-- > example = ["This is an example", "of", "interactive", "evaluation"]
16+
-- >
17+
-- > -- >>> intercalate " " example
18+
-- > -- "This is an example of interactive evaluation"
19+
-- > --
20+
--
21+
-- [1] - https://github.com/jyp/dante
22+
module Ide.Plugin.Eval where
23+
24+
import Control.Monad (void)
25+
import Control.Monad.Catch (finally)
26+
import Control.Monad.IO.Class (MonadIO (liftIO))
27+
import Control.Monad.Trans.Class (MonadTrans (lift))
28+
import Control.Monad.Trans.Except (ExceptT (..), runExceptT,
29+
throwE)
30+
import Data.Aeson (FromJSON, ToJSON, Value (Null),
31+
toJSON)
32+
import Data.Bifunctor (Bifunctor (first))
33+
import qualified Data.HashMap.Strict as Map
34+
import qualified Data.Rope.UTF16 as Rope
35+
import Data.String (IsString (fromString))
36+
import Data.Text (Text)
37+
import qualified Data.Text as T
38+
import Data.Time (getCurrentTime)
39+
import Development.IDE.Core.Rules (runAction)
40+
import Development.IDE.Core.RuleTypes (GetModSummary (..),
41+
GhcSessionDeps (..))
42+
import Development.IDE.Core.Shake (use_)
43+
import Development.IDE.GHC.Util (evalGhcEnv, hscEnv,
44+
textToStringBuffer)
45+
import Development.IDE.Types.Location (toNormalizedFilePath',
46+
uriToFilePath')
47+
import DynamicLoading (initializePlugins)
48+
import GHC
49+
import GHC.Generics (Generic)
50+
import GhcMonad (modifySession)
51+
import GhcPlugins (defaultLogActionHPutStrDoc,
52+
gopt_set, gopt_unset,
53+
interpWays, updateWays,
54+
wayGeneralFlags,
55+
wayUnsetGeneralFlags)
56+
import HscTypes
57+
import Ide.Plugin
58+
import Ide.Types
59+
import Language.Haskell.LSP.Core (LspFuncs (getVirtualFileFunc))
60+
import Language.Haskell.LSP.Types
61+
import Language.Haskell.LSP.VFS (VirtualFile (..))
62+
import PrelNames (pRELUDE)
63+
import System.IO (IOMode (WriteMode), hClose, openFile)
64+
import System.IO.Extra (newTempFile)
65+
66+
descriptor :: PluginId -> PluginDescriptor
67+
descriptor plId =
68+
(defaultPluginDescriptor plId)
69+
{ pluginId = plId,
70+
pluginCodeLensProvider = Just provider,
71+
pluginCommands = [evalCommand]
72+
}
73+
74+
extractMatches :: Maybe Text -> [([(Text, Int)], Range)]
75+
extractMatches = goSearch 0 . maybe [] T.lines
76+
where
77+
checkMatch = T.stripPrefix "-- >>> "
78+
looksLikeSplice l
79+
| Just l' <- T.stripPrefix "--" l
80+
= not (" >>>" `T.isPrefixOf` l')
81+
| otherwise
82+
= False
83+
84+
goSearch _ [] = []
85+
goSearch line (l : ll)
86+
| Just match <- checkMatch l =
87+
goAcc (line + 1) [(match, line)] ll
88+
| otherwise =
89+
goSearch (line + 1) ll
90+
91+
goAcc line acc [] = [(reverse acc,Range p p)] where p = Position line 0
92+
goAcc line acc (l:ll)
93+
| Just match <- checkMatch l =
94+
goAcc (line + 1) ([(match, line)] <> acc) ll
95+
| otherwise =
96+
(reverse acc,r) : goSearch (line + 1) ll
97+
where
98+
r = Range p p'
99+
p = Position line 0
100+
p' = Position (line + spliceLength) 0
101+
spliceLength = length (takeWhile looksLikeSplice (l:ll))
102+
103+
provider :: CodeLensProvider
104+
provider lsp _state plId CodeLensParams {_textDocument} = response $ do
105+
let TextDocumentIdentifier uri = _textDocument
106+
contents <- liftIO $ getVirtualFileFunc lsp $ toNormalizedUri uri
107+
let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
108+
let matches = extractMatches text
109+
110+
cmd <- liftIO $ mkLspCommand plId evalCommandName "Evaluate..." (Just [])
111+
112+
let lenses =
113+
[ CodeLens range (Just cmd') Nothing
114+
| (m, r) <- matches,
115+
let (_, startLine) = head m
116+
(_, endLine) = last m
117+
range = Range start end
118+
start = Position startLine 0
119+
end = Position endLine 1000
120+
args = EvalParams m r _textDocument,
121+
let cmd' = (cmd :: Command)
122+
{_arguments = Just (List [toJSON args])
123+
,_title = if trivial r then "Evaluate..." else "Refresh..."
124+
}
125+
]
126+
127+
return $ List lenses
128+
where
129+
trivial (Range p p') = p == p'
130+
131+
evalCommandName :: CommandId
132+
evalCommandName = "evalCommand"
133+
134+
evalCommand :: PluginCommand
135+
evalCommand =
136+
PluginCommand evalCommandName "evaluate" runEvalCmd
137+
138+
data EvalParams = EvalParams
139+
{ statements :: [(Text, Int)],
140+
editTarget :: !Range,
141+
module_ :: !TextDocumentIdentifier
142+
}
143+
deriving (Eq, Show, Generic, FromJSON, ToJSON)
144+
145+
runEvalCmd :: CommandFunction EvalParams
146+
runEvalCmd lsp state EvalParams {..} = response' $ do
147+
let TextDocumentIdentifier {_uri} = module_
148+
fp <- handleMaybe "uri" $ uriToFilePath' _uri
149+
contents <- liftIO $ getVirtualFileFunc lsp $ toNormalizedUri _uri
150+
text <- handleMaybe "contents" $ Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
151+
152+
session <-
153+
liftIO
154+
$ runAction "runEvalCmd.ghcSession" state
155+
$ use_ GhcSessionDeps
156+
$ toNormalizedFilePath'
157+
$ fp
158+
159+
ms <-
160+
liftIO
161+
$ runAction "runEvalCmd.getModSummary" state
162+
$ use_ GetModSummary
163+
$ toNormalizedFilePath'
164+
$ fp
165+
166+
now <- liftIO getCurrentTime
167+
168+
(temp, clean) <- liftIO newTempFile
169+
(tempLog, cleanLog) <- liftIO newTempFile
170+
hLog <- liftIO $ openFile tempLog WriteMode
171+
flip finally (liftIO $ hClose hLog >> cleanLog >> clean) $ do
172+
let modName = moduleName $ ms_mod ms
173+
thisModuleTarget = Target (TargetFile fp Nothing) False (Just (textToStringBuffer text, now))
174+
175+
hscEnv' <- ExceptT $ evalGhcEnv (hscEnv session) $ do
176+
df <- getSessionDynFlags
177+
env <- getSession
178+
df <- liftIO $ setupDynFlagsForGHCiLike env df
179+
_lp <- setSessionDynFlags df
180+
181+
-- copy the package state to the interactive DynFlags
182+
idflags <- getInteractiveDynFlags
183+
df <- getSessionDynFlags
184+
setInteractiveDynFlags
185+
idflags
186+
{ pkgState = pkgState df,
187+
pkgDatabase = pkgDatabase df,
188+
packageFlags = packageFlags df
189+
}
190+
191+
-- set up a custom log action
192+
setLogAction $ \_df _wr _sev _span _style _doc ->
193+
defaultLogActionHPutStrDoc _df hLog _doc _style
194+
195+
-- load the module in the interactive environment
196+
setTargets [thisModuleTarget]
197+
loadResult <- load LoadAllTargets
198+
case loadResult of
199+
Failed -> liftIO $ do
200+
hClose hLog
201+
Left <$> readFile tempLog
202+
Succeeded -> do
203+
setContext [IIDecl (simpleImportDecl $ moduleName pRELUDE), IIModule modName]
204+
Right <$> getSession
205+
206+
df <- liftIO $ evalGhcEnv hscEnv' getSessionDynFlags
207+
let eval (stmt, l)
208+
| isStmt df stmt = do
209+
210+
-- set up a custom interactive print function
211+
ctxt <- getContext
212+
setContext [IIDecl (simpleImportDecl $ moduleName pRELUDE)]
213+
let printFun = "let ghcideCustomShow x = Prelude.writeFile " <> show temp <> " (Prelude.show x)"
214+
interactivePrint <- execStmt printFun execOptions >>= \case
215+
ExecComplete (Right [interactivePrint]) _ -> pure interactivePrint
216+
_ -> error "internal error binding print function"
217+
modifySession $ \hsc -> hsc {hsc_IC = setInteractivePrintName (hsc_IC hsc) interactivePrint}
218+
setContext ctxt
219+
220+
let opts =
221+
execOptions
222+
{ execSourceFile = fp,
223+
execLineNumber = l
224+
}
225+
res <- execStmt stmt opts
226+
str <- case res of
227+
ExecComplete (Left err) _ -> pure $ pad $ show err
228+
ExecComplete (Right _) _ -> liftIO $ pad <$> readFile temp
229+
ExecBreak {} -> pure $ pad "breakpoints are not supported"
230+
231+
let changes = [TextEdit editTarget $ T.pack str]
232+
return changes
233+
234+
| isImport df stmt = do
235+
ctxt <- getContext
236+
idecl <- parseImportDecl stmt
237+
setContext $ IIDecl idecl : ctxt
238+
return []
239+
240+
| otherwise = do
241+
void $ runDecls stmt
242+
return []
243+
244+
edits <- liftIO $ evalGhcEnv hscEnv' $ traverse (eval . first T.unpack) statements
245+
246+
let workspaceEditsMap = Map.fromList [(_uri, List $ concat edits)]
247+
let workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing
248+
249+
return (WorkspaceApplyEdit, ApplyWorkspaceEditParams workspaceEdits)
250+
251+
pad :: String -> String
252+
pad = unlines . map ("-- " <>) . lines
253+
254+
-------------------------------------------------------------------------------
255+
256+
handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b
257+
handleMaybe msg = maybe (throwE msg) return
258+
259+
handleMaybeM :: Monad m => e -> m (Maybe b) -> ExceptT e m b
260+
handleMaybeM msg act = maybe (throwE msg) return =<< lift act
261+
262+
response :: ExceptT String IO a -> IO (Either ResponseError a)
263+
response =
264+
fmap (first (\msg -> ResponseError InternalError (fromString msg) Nothing))
265+
. runExceptT
266+
267+
response' :: ExceptT String IO a -> IO (Either ResponseError Value, Maybe a)
268+
response' act = do
269+
res <- runExceptT act
270+
case res of
271+
Left e ->
272+
return (Left (ResponseError InternalError (fromString e) Nothing), Nothing)
273+
Right a -> return (Right Null, Just a)
274+
275+
setupDynFlagsForGHCiLike :: HscEnv -> DynFlags -> IO DynFlags
276+
setupDynFlagsForGHCiLike env dflags = do
277+
let dflags3 =
278+
dflags
279+
{ hscTarget = HscInterpreted,
280+
ghcMode = CompManager,
281+
ghcLink = LinkInMemory
282+
}
283+
platform = targetPlatform dflags3
284+
dflags3a = updateWays $ dflags3 {ways = interpWays}
285+
dflags3b =
286+
foldl gopt_set dflags3a $
287+
concatMap
288+
(wayGeneralFlags platform)
289+
interpWays
290+
dflags3c =
291+
foldl gopt_unset dflags3b $
292+
concatMap
293+
(wayUnsetGeneralFlags platform)
294+
interpWays
295+
dflags4 =
296+
dflags3c `gopt_set` Opt_ImplicitImportQualified
297+
`gopt_set` Opt_IgnoreOptimChanges
298+
`gopt_set` Opt_IgnoreHpcChanges
299+
initializePlugins env dflags4

0 commit comments

Comments
 (0)