Skip to content

Commit ee0768d

Browse files
konnkonn
authored
Implements :type [+v/+d] in Eval Plugin (#361)
* More systematic handling of GHCi-like commands * Human-readable Show for GhciLikeCmdException * Use `T.strip` instead of `T.stripEnd` * Implements `:type` command and their tests * Adds test case for unknown `TcRnExprMode` argument * Adds test case for unknown command * Simplifies test case T16 * Corrects mode option * Adds test-case with defaulting clause inside >>> prompt * Fixes for redundant imports * Reorganises import list * Elaborates on the Exception argument roles * Adds a test-case for module defaulting, marked as expected failure * Uses `expectFailBecause` instead
1 parent baabffd commit ee0768d

File tree

16 files changed

+160
-20
lines changed

16 files changed

+160
-20
lines changed

‎src/Ide/Plugin/Eval.hs‎

Lines changed: 65 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -21,6 +21,11 @@
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+
)
2429
import Control.Monad (void)
2530
import Control.Monad.IO.Class (MonadIO (liftIO))
2631
import Control.Monad.Trans.Class (MonadTrans (lift))
@@ -29,7 +34,9 @@ import Control.Monad.Trans.Except (ExceptT (..), runExceptT,
2934
import Data.Aeson (FromJSON, ToJSON, Value (Null),
3035
toJSON)
3136
import Data.Bifunctor (Bifunctor (first))
37+
import Data.Char (isSpace)
3238
import qualified Data.HashMap.Strict as Map
39+
import Data.Maybe (catMaybes)
3340
import Data.String (IsString (fromString))
3441
import Data.Text (Text)
3542
import qualified Data.Text as T
@@ -44,14 +51,15 @@ import Development.IDE.Types.Location (toNormalizedFilePath',
4451
uriToFilePath')
4552
import DynamicLoading (initializePlugins)
4653
import DynFlags (targetPlatform)
47-
import GHC (DynFlags, ExecResult (..), GeneralFlag (Opt_IgnoreHpcChanges, Opt_IgnoreOptimChanges, Opt_ImplicitImportQualified),
54+
import GHC (Ghc, TcRnExprMode(..), DynFlags, ExecResult (..), GeneralFlag (Opt_IgnoreHpcChanges, Opt_IgnoreOptimChanges, Opt_ImplicitImportQualified),
4855
GhcLink (LinkInMemory),
4956
GhcMode (CompManager),
5057
HscTarget (HscInterpreted),
5158
LoadHowMuch (LoadAllTargets),
5259
SuccessFlag (..),
5360
execLineNumber, execOptions,
5461
execSourceFile, execStmt,
62+
exprType,
5563
getContext,
5664
getInteractiveDynFlags,
5765
getSession, getSessionDynFlags,
@@ -77,17 +85,12 @@ import Ide.Types
7785
import Language.Haskell.LSP.Core (LspFuncs (getVirtualFileFunc))
7886
import Language.Haskell.LSP.Types
7987
import Language.Haskell.LSP.VFS (virtualFileText)
88+
import Outputable (ppr, showSDoc)
8089
import PrelNames (pRELUDE)
8190
import System.FilePath
8291
import System.IO (hClose)
8392
import System.IO.Temp
84-
import Data.Maybe (catMaybes)
85-
import qualified Control.Exception as E
86-
import Control.DeepSeq ( NFData
87-
, deepseq
88-
)
89-
import Outputable (Outputable(ppr), showSDoc)
90-
import Control.Applicative ((<|>))
93+
import Type.Reflection (Typeable)
9194

9295
descriptor :: PluginId -> PluginDescriptor
9396
descriptor plId =
@@ -247,18 +250,8 @@ done, we want to switch back to GhcSessionDeps:
247250

248251
df <- liftIO $ evalGhcEnv hscEnv' getSessionDynFlags
249252
let eval (stmt, l)
250-
| let stmt0 = T.strip $ T.pack stmt -- For stripping and de-prefixing
251-
, Just (reduce, type_) <-
252-
(True,) <$> T.stripPrefix ":kind! " stmt0
253-
<|> (False,) <$> T.stripPrefix ":kind " stmt0
254-
= do
255-
let input = T.strip type_
256-
(ty, kind) <- typeKind reduce $ T.unpack input
257-
pure $ Just
258-
$ T.unlines
259-
$ map ("-- " <>)
260-
$ (input <> " :: " <> T.pack (showSDoc df $ ppr kind))
261-
: [ "= " <> T.pack (showSDoc df $ ppr ty) | reduce]
253+
| Just (cmd, arg) <- parseGhciLikeCmd $ T.pack stmt
254+
= evalGhciLikeCmd cmd arg
262255
| isStmt df stmt = do
263256
-- set up a custom interactive print function
264257
liftIO $ writeFile temp ""
@@ -309,6 +302,58 @@ done, we want to switch back to GhcSessionDeps:
309302

310303
return (WorkspaceApplyEdit, ApplyWorkspaceEditParams workspaceEdits)
311304

305+
evalGhciLikeCmd :: Text -> Text -> Ghc (Maybe Text)
306+
evalGhciLikeCmd cmd arg = do
307+
df <- getSessionDynFlags
308+
let tppr = T.pack . showSDoc df . ppr
309+
case cmd of
310+
"kind" -> do
311+
let input = T.strip arg
312+
(_, kind) <- typeKind False $ T.unpack input
313+
pure $ Just $ "-- " <> input <> " :: " <> tppr kind <> "\n"
314+
"kind!" -> do
315+
let input = T.strip arg
316+
(ty, kind) <- typeKind True $ T.unpack input
317+
pure
318+
$ Just
319+
$ T.unlines
320+
$ map ("-- " <>)
321+
[ input <> " :: " <> tppr kind
322+
, "= " <> tppr ty
323+
]
324+
"type" -> do
325+
let (emod, expr) = parseExprMode arg
326+
ty <- exprType emod $ T.unpack expr
327+
pure $ Just $
328+
"-- " <> expr <> " :: " <> tppr ty <> "\n"
329+
_ -> E.throw $ GhciLikeCmdNotImplemented cmd arg
330+
331+
parseExprMode :: Text -> (TcRnExprMode, T.Text)
332+
parseExprMode rawArg =
333+
case T.break isSpace rawArg of
334+
("+v", rest) -> (TM_NoInst, T.strip rest)
335+
("+d", rest) -> (TM_Default, T.strip rest)
336+
_ -> (TM_Inst, rawArg)
337+
338+
data GhciLikeCmdException =
339+
GhciLikeCmdNotImplemented
340+
{ ghciCmdName :: Text
341+
, ghciCmdArg :: Text
342+
}
343+
deriving (Typeable)
344+
345+
instance Show GhciLikeCmdException where
346+
showsPrec _ GhciLikeCmdNotImplemented{..} =
347+
showString "unknown command '" .
348+
showString (T.unpack ghciCmdName) . showChar '\''
349+
350+
instance E.Exception GhciLikeCmdException
351+
352+
parseGhciLikeCmd :: Text -> Maybe (Text, Text)
353+
parseGhciLikeCmd input = do
354+
(':', rest) <- T.uncons $ T.stripStart input
355+
pure $ second T.strip $ T.break isSpace rest
356+
312357
strictTry :: NFData b => IO b -> IO (Either String b)
313358
strictTry op = E.catch
314359
(op >>= \v -> return $! Right $! deepseq v v)

‎test/functional/Eval.hs‎

Lines changed: 16 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,7 @@ import Language.Haskell.LSP.Types ( ApplyWorkspaceEditRequest
2525
import System.FilePath
2626
import Test.Hls.Util
2727
import Test.Tasty
28+
import Test.Tasty.ExpectedFailure (expectFailBecause)
2829
import Test.Tasty.HUnit
2930

3031
tests :: TestTree
@@ -70,6 +71,21 @@ tests = testGroup
7071
, testCase "Shows a kind with :kind" $ goldenTest "T12.hs"
7172
, testCase "Reports an error for an incorrect type with :kind"
7273
$ goldenTest "T13.hs"
74+
, testCase "Returns a fully-instantiated type for :type"
75+
$ goldenTest "T14.hs"
76+
, testCase "Returns an uninstantiated type for :type +v, admitting multiple whitespaces around arguments"
77+
$ goldenTest "T15.hs"
78+
, testCase "Returns defaulted type for :type +d, admitting multiple whitespaces around arguments"
79+
$ goldenTest "T16.hs"
80+
, testCase ":type reports an error when given with unknown +x option"
81+
$ goldenTest "T17.hs"
82+
, testCase "Reports an error when given with unknown command"
83+
$ goldenTest "T18.hs"
84+
, testCase "Returns defaulted type for :type +d reflecting the default declaration specified in the >>> prompt"
85+
$ goldenTest "T19.hs"
86+
, expectFailBecause "known issue - see a note in P.R. #361"
87+
$ testCase ":type +d reflects the `default' declaration of the module"
88+
$ goldenTest "T20.hs"
7389
]
7490

7591
goldenTest :: FilePath -> IO ()

‎test/testdata/eval/T14.hs‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,7 @@
1+
{-# LANGUAGE TypeApplications #-}
2+
module T14 where
3+
4+
foo :: Show a => a -> String
5+
foo = show
6+
7+
-- >>> :type foo @Int

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

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,8 @@
1+
{-# LANGUAGE TypeApplications #-}
2+
module T14 where
3+
4+
foo :: Show a => a -> String
5+
foo = show
6+
7+
-- >>> :type foo @Int
8+
-- foo @Int :: Int -> String

‎test/testdata/eval/T15.hs‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,7 @@
1+
{-# LANGUAGE TypeApplications #-}
2+
module T15 where
3+
4+
foo :: Show a => a -> String
5+
foo = show
6+
7+
-- >>> :type +v foo @Int

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

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,8 @@
1+
{-# LANGUAGE TypeApplications #-}
2+
module T15 where
3+
4+
foo :: Show a => a -> String
5+
foo = show
6+
7+
-- >>> :type +v foo @Int
8+
-- foo @Int :: Show Int => Int -> String

‎test/testdata/eval/T16.hs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
module T16 where
2+
3+
-- >>> :type +d 40+ 2

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

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
module T16 where
2+
3+
-- >>> :type +d 40+ 2
4+
-- 40+ 2 :: Integer

‎test/testdata/eval/T17.hs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
module T17 where
2+
3+
-- >>> :type +no 42

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

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
module T17 where
2+
3+
-- >>> :type +no 42
4+
-- parse error on input ‘+’

0 commit comments

Comments
 (0)