Skip to content

Commit 8a71972

Browse files
konnkonn
authored
Eval plugin: proper multilined results handling and command-name abbreviations (#413)
* Fixes Eval plugin to treat multilined results properly and supports abbreviation for GHCi commands * Re-orders Pragmas * Cosmetic changes * More correction for LANGUAGE pragma style * Integrates commenting-out works into `evalGhciLikeCmd`
1 parent 5115bbb commit 8a71972

File tree

12 files changed

+284
-95
lines changed

12 files changed

+284
-95
lines changed

‎plugins/default/src/Ide/Plugin/Eval.hs

+103-78
Original file line numberDiff line numberDiff line change
@@ -21,69 +21,66 @@
2121
-- [1] - https://github.com/jyp/dante
2222
module Ide.Plugin.Eval where
2323

24-
import Control.Arrow (second)
25-
import qualified Control.Exception as E
26-
import Control.DeepSeq ( NFData
27-
, deepseq
28-
)
29-
import Control.Monad (void)
30-
import Control.Monad.IO.Class (MonadIO (liftIO))
31-
import Control.Monad.Trans.Class (MonadTrans (lift))
32-
import Control.Monad.Trans.Except (ExceptT (..), runExceptT,
33-
throwE)
34-
import Data.Aeson (FromJSON, ToJSON, Value (Null),
35-
toJSON)
36-
import Data.Bifunctor (Bifunctor (first))
37-
import Data.Char (isSpace)
38-
import qualified Data.HashMap.Strict as Map
39-
import Data.Maybe (catMaybes)
40-
import Data.String (IsString (fromString))
41-
import Data.Text (Text)
42-
import qualified Data.Text as T
43-
import Data.Time (getCurrentTime)
24+
import Control.Applicative (Alternative ((<|>)))
25+
import Control.Arrow (second)
26+
import Control.DeepSeq (NFData, deepseq)
27+
import qualified Control.Exception as E
28+
import Control.Monad (void)
29+
import Control.Monad.IO.Class (MonadIO (liftIO))
30+
import Control.Monad.Trans.Class (MonadTrans (lift))
31+
import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE)
32+
import Data.Aeson (FromJSON, ToJSON, Value (Null),
33+
toJSON)
34+
import Data.Bifunctor (Bifunctor (first))
35+
import Data.Char (isSpace)
36+
import qualified Data.HashMap.Strict as Map
37+
import Data.List (find)
38+
import Data.Maybe (catMaybes)
39+
import Data.String (IsString (fromString))
40+
import Data.Text (Text)
41+
import qualified Data.Text as T
42+
import Data.Time (getCurrentTime)
4443
import Development.IDE
45-
import DynamicLoading (initializePlugins)
46-
import DynFlags (targetPlatform)
47-
import Development.IDE.GHC.Compat (Ghc, TcRnExprMode(..), DynFlags, ExecResult (..), GeneralFlag (Opt_IgnoreHpcChanges, Opt_IgnoreOptimChanges, Opt_ImplicitImportQualified),
48-
GhcLink (LinkInMemory),
49-
GhcMode (CompManager),
50-
HscTarget (HscInterpreted),
51-
LoadHowMuch (LoadAllTargets),
52-
SuccessFlag (..),
53-
execLineNumber, execOptions,
54-
execSourceFile, execStmt,
55-
exprType,
56-
getContext,
57-
getInteractiveDynFlags,
58-
getSession, getSessionDynFlags,
59-
ghcLink, ghcMode, hscTarget,
60-
isImport, isStmt, load,
61-
moduleName, packageFlags,
62-
parseImportDecl, pkgDatabase,
63-
pkgState, runDecls, setContext,
64-
setInteractiveDynFlags,
65-
setLogAction,
66-
setSessionDynFlags, setTargets,
67-
simpleImportDecl, typeKind, ways)
68-
import GHC.Generics (Generic)
69-
import GhcMonad (modifySession)
70-
import GhcPlugins (defaultLogActionHPutStrDoc,
71-
gopt_set, gopt_unset,
72-
interpWays, updateWays,
73-
wayGeneralFlags,
74-
wayUnsetGeneralFlags)
44+
import Development.IDE.GHC.Compat (DynFlags, ExecResult (..), GeneralFlag (Opt_IgnoreHpcChanges, Opt_IgnoreOptimChanges, Opt_ImplicitImportQualified),
45+
Ghc, GhcLink (LinkInMemory),
46+
GhcMode (CompManager),
47+
HscTarget (HscInterpreted),
48+
LoadHowMuch (LoadAllTargets),
49+
SuccessFlag (..),
50+
TcRnExprMode (..), execLineNumber,
51+
execOptions, execSourceFile,
52+
execStmt, exprType, getContext,
53+
getInteractiveDynFlags, getSession,
54+
getSessionDynFlags, ghcLink,
55+
ghcMode, hscTarget, isImport,
56+
isStmt, load, moduleName,
57+
packageFlags, parseImportDecl,
58+
pkgDatabase, pkgState, runDecls,
59+
setContext, setInteractiveDynFlags,
60+
setLogAction, setSessionDynFlags,
61+
setTargets, simpleImportDecl,
62+
typeKind, ways)
63+
import DynamicLoading (initializePlugins)
64+
import DynFlags (targetPlatform)
65+
import GHC.Generics (Generic)
66+
import GhcMonad (modifySession)
67+
import GhcPlugins (defaultLogActionHPutStrDoc,
68+
gopt_set, gopt_unset, interpWays,
69+
updateWays, wayGeneralFlags,
70+
wayUnsetGeneralFlags)
7571
import HscTypes
7672
import Ide.Plugin
7773
import Ide.Types
7874
import Language.Haskell.LSP.Core
7975
import Language.Haskell.LSP.Types
80-
import Language.Haskell.LSP.VFS (virtualFileText)
81-
import Outputable (ppr, showSDoc)
82-
import PrelNames (pRELUDE)
76+
import Language.Haskell.LSP.VFS (virtualFileText)
77+
import Outputable (nest, ppr, showSDoc, text, ($$),
78+
(<+>))
79+
import PrelNames (pRELUDE)
8380
import System.FilePath
84-
import System.IO (hClose)
81+
import System.IO (hClose)
8582
import System.IO.Temp
86-
import Type.Reflection (Typeable)
83+
import Type.Reflection (Typeable)
8784

8885
descriptor :: PluginId -> PluginDescriptor
8986
descriptor plId =
@@ -280,38 +277,66 @@ runEvalCmd lsp state EvalParams {..} = withIndefiniteProgress lsp "Eval" Cancell
280277

281278
return (WorkspaceApplyEdit, ApplyWorkspaceEditParams workspaceEdits)
282279

280+
-- | Resulting @Text@ MUST NOT prefix each line with @--@
281+
-- Such comment-related post-process will be taken place
282+
-- solely in 'evalGhciLikeCmd'.
283+
type GHCiLikeCmd = DynFlags -> Text -> Ghc (Maybe Text)
284+
285+
-- Should we use some sort of trie here?
286+
ghciLikeCommands :: [(Text, GHCiLikeCmd)]
287+
ghciLikeCommands =
288+
[ ("kind", doKindCmd False)
289+
, ("kind!", doKindCmd True)
290+
, ("type", doTypeCmd)
291+
]
292+
283293
evalGhciLikeCmd :: Text -> Text -> Ghc (Maybe Text)
284294
evalGhciLikeCmd cmd arg = do
285295
df <- getSessionDynFlags
286-
let tppr = T.pack . showSDoc df . ppr
287-
case cmd of
288-
"kind" -> do
289-
let input = T.strip arg
290-
(_, kind) <- typeKind False $ T.unpack input
291-
pure $ Just $ "-- " <> input <> " :: " <> tppr kind <> "\n"
292-
"kind!" -> do
293-
let input = T.strip arg
294-
(ty, kind) <- typeKind True $ T.unpack input
295-
pure
296-
$ Just
297-
$ T.unlines
298-
$ map ("-- " <>)
299-
[ input <> " :: " <> tppr kind
300-
, "= " <> tppr ty
301-
]
302-
"type" -> do
303-
let (emod, expr) = parseExprMode arg
304-
ty <- exprType emod $ T.unpack expr
305-
pure $ Just $
306-
"-- " <> expr <> " :: " <> tppr ty <> "\n"
307-
_ -> E.throw $ GhciLikeCmdNotImplemented cmd arg
296+
case lookup cmd ghciLikeCommands
297+
<|> snd <$> find (T.isPrefixOf cmd . fst) ghciLikeCommands of
298+
Just hndler ->
299+
fmap
300+
(T.unlines . map ("-- " <>) . T.lines
301+
)
302+
<$> hndler df arg
303+
_ -> E.throw $ GhciLikeCmdNotImplemented cmd arg
304+
305+
doKindCmd :: Bool -> DynFlags -> Text -> Ghc (Maybe Text)
306+
doKindCmd False df arg = do
307+
let input = T.strip arg
308+
(_, kind) <- typeKind False $ T.unpack input
309+
let kindText = text (T.unpack input) <+> "::" <+> ppr kind
310+
pure $ Just $ T.pack (showSDoc df kindText)
311+
doKindCmd True df arg = do
312+
let input = T.strip arg
313+
(ty, kind) <- typeKind True $ T.unpack input
314+
let kindDoc = text (T.unpack input) <+> "::" <+> ppr kind
315+
tyDoc = "=" <+> ppr ty
316+
pure $ Just $ T.pack (showSDoc df $ kindDoc $$ tyDoc)
317+
318+
doTypeCmd :: DynFlags -> Text -> Ghc (Maybe Text)
319+
doTypeCmd dflags arg = do
320+
let (emod, expr) = parseExprMode arg
321+
ty <- exprType emod $ T.unpack expr
322+
let rawType = T.strip $ T.pack $ showSDoc dflags $ ppr ty
323+
broken = T.any (\c -> c == '\r' || c == '\n') rawType
324+
pure $ Just $
325+
if broken
326+
then T.pack
327+
$ showSDoc dflags
328+
$ text (T.unpack expr) $$
329+
(nest 2 $
330+
"::" <+> ppr ty
331+
)
332+
else expr <> " :: " <> rawType <> "\n"
308333

309334
parseExprMode :: Text -> (TcRnExprMode, T.Text)
310335
parseExprMode rawArg =
311336
case T.break isSpace rawArg of
312337
("+v", rest) -> (TM_NoInst, T.strip rest)
313338
("+d", rest) -> (TM_Default, T.strip rest)
314-
_ -> (TM_Inst, rawArg)
339+
_ -> (TM_Inst, rawArg)
315340

316341
data GhciLikeCmdException =
317342
GhciLikeCmdNotImplemented

‎test/functional/Eval.hs

+19-17
Original file line numberDiff line numberDiff line change
@@ -7,25 +7,17 @@ module Eval
77
)
88
where
99

10-
import Control.Applicative.Combinators
11-
( skipManyTill )
12-
import Control.Monad.IO.Class ( MonadIO(liftIO) )
13-
import qualified Data.Text.IO as T
10+
import Control.Applicative.Combinators (skipManyTill)
11+
import Control.Monad.IO.Class (MonadIO (liftIO))
12+
import qualified Data.Text.IO as T
1413
import Language.Haskell.LSP.Test
15-
import Language.Haskell.LSP.Types ( ApplyWorkspaceEditRequest
16-
, CodeLens
17-
( CodeLens
18-
, _command
19-
, _range
20-
)
21-
, Command(_title)
22-
, Position(..)
23-
, Range(..)
24-
)
14+
import Language.Haskell.LSP.Types (ApplyWorkspaceEditRequest, CodeLens (CodeLens, _command, _range),
15+
Command (_title),
16+
Position (..), Range (..))
2517
import System.FilePath
2618
import Test.Hls.Util
2719
import Test.Tasty
28-
import Test.Tasty.ExpectedFailure (expectFailBecause)
20+
import Test.Tasty.ExpectedFailure (expectFailBecause)
2921
import Test.Tasty.HUnit
3022

3123
tests :: TestTree
@@ -66,10 +58,10 @@ tests = testGroup
6658
, testCase "Evaluate incorrect expressions" $ goldenTest "T8.hs"
6759
, testCase "Applies file LANGUAGE extensions" $ goldenTest "T9.hs"
6860
, testCase "Evaluate a type with :kind!" $ goldenTest "T10.hs"
69-
, testCase "Reports an error for an incorrect type with :kind!"
61+
, testCase "Reports an error for an incorrect type with :kind!"
7062
$ goldenTest "T11.hs"
7163
, testCase "Shows a kind with :kind" $ goldenTest "T12.hs"
72-
, testCase "Reports an error for an incorrect type with :kind"
64+
, testCase "Reports an error for an incorrect type with :kind"
7365
$ goldenTest "T13.hs"
7466
, testCase "Returns a fully-instantiated type for :type"
7567
$ goldenTest "T14.hs"
@@ -86,6 +78,16 @@ tests = testGroup
8678
, expectFailBecause "known issue - see a note in P.R. #361"
8779
$ testCase ":type +d reflects the `default' declaration of the module"
8880
$ goldenTest "T20.hs"
81+
, testCase ":type handles a multilined result properly"
82+
$ goldenTest "T21.hs"
83+
, testCase ":t behaves exactly the same as :type"
84+
$ goldenTest "T22.hs"
85+
, testCase ":type does \"dovetails\" for short identifiers"
86+
$ goldenTest "T23.hs"
87+
, testCase ":kind! treats a multilined result properly"
88+
$ goldenTest "T24.hs"
89+
, testCase ":kind treats a multilined result properly"
90+
$ goldenTest "T25.hs"
8991
]
9092

9193
goldenTest :: FilePath -> IO ()

‎test/testdata/eval/T21.hs

+12
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,12 @@
1+
{-# LANGUAGE PolyKinds #-}
2+
{-# LANGUAGE ScopedTypeVariables #-}
3+
module T21 where
4+
import Data.Proxy (Proxy(..))
5+
import GHC.TypeNats (KnownNat)
6+
import Type.Reflection (Typeable)
7+
8+
fun :: forall k n a. (KnownNat k, KnownNat n, Typeable a)
9+
=> Proxy k -> Proxy n -> Proxy a -> ()
10+
fun _ _ _ = ()
11+
12+
-- >>> :type fun

‎test/testdata/eval/T21.hs.expected

+16
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,16 @@
1+
{-# LANGUAGE PolyKinds #-}
2+
{-# LANGUAGE ScopedTypeVariables #-}
3+
module T21 where
4+
import Data.Proxy (Proxy(..))
5+
import GHC.TypeNats (KnownNat)
6+
import Type.Reflection (Typeable)
7+
8+
fun :: forall k n a. (KnownNat k, KnownNat n, Typeable a)
9+
=> Proxy k -> Proxy n -> Proxy a -> ()
10+
fun _ _ _ = ()
11+
12+
-- >>> :type fun
13+
-- fun
14+
-- :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).
15+
-- (KnownNat k2, KnownNat n, Typeable a) =>
16+
-- Proxy k2 -> Proxy n -> Proxy a -> ()

‎test/testdata/eval/T22.hs

+9
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,9 @@
1+
module T22 where
2+
import Data.Proxy (Proxy (..))
3+
import GHC.TypeNats (KnownNat)
4+
import Type.Reflection (Typeable)
5+
6+
f :: Integer
7+
f = 32
8+
9+
-- >>> :t f

‎test/testdata/eval/T22.hs.expected

+10
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,10 @@
1+
module T22 where
2+
import Data.Proxy (Proxy (..))
3+
import GHC.TypeNats (KnownNat)
4+
import Type.Reflection (Typeable)
5+
6+
f :: Integer
7+
f = 32
8+
9+
-- >>> :t f
10+
-- f :: Integer

‎test/testdata/eval/T23.hs

+12
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,12 @@
1+
{-# LANGUAGE PolyKinds #-}
2+
{-# LANGUAGE ScopedTypeVariables #-}
3+
module T23 where
4+
import Data.Proxy (Proxy (..))
5+
import GHC.TypeNats (KnownNat)
6+
import Type.Reflection (Typeable)
7+
8+
f :: forall k n a. (KnownNat k, KnownNat n, Typeable a)
9+
=> Proxy k -> Proxy n -> Proxy a -> ()
10+
f _ _ _ = ()
11+
12+
-- >>> :type f

‎test/testdata/eval/T23.hs.expected

+15
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,15 @@
1+
{-# LANGUAGE PolyKinds #-}
2+
{-# LANGUAGE ScopedTypeVariables #-}
3+
module T23 where
4+
import Data.Proxy (Proxy (..))
5+
import GHC.TypeNats (KnownNat)
6+
import Type.Reflection (Typeable)
7+
8+
f :: forall k n a. (KnownNat k, KnownNat n, Typeable a)
9+
=> Proxy k -> Proxy n -> Proxy a -> ()
10+
f _ _ _ = ()
11+
12+
-- >>> :type f
13+
-- f :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).
14+
-- (KnownNat k2, KnownNat n, Typeable a) =>
15+
-- Proxy k2 -> Proxy n -> Proxy a -> ()

‎test/testdata/eval/T24.hs

+14
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,14 @@
1+
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE PolyKinds #-}
3+
{-# LANGUAGE TypeFamilies #-}
4+
{-# LANGUAGE TypeOperators #-}
5+
{-# LANGUAGE UndecidableInstances #-}
6+
module T24 where
7+
import GHC.TypeNats (type (-))
8+
data Proxy a = Stop | Next (Proxy a)
9+
10+
type family LongP n a where
11+
LongP 0 a = a
12+
LongP n a = Next (LongP (n - 1) a)
13+
14+
-- >>> :kind! ((LongP 10 Stop) :: Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy Double)))))))))))))

0 commit comments

Comments
 (0)