Implements :type [+v/+d] in Eval Plugin

src/Ide/Plugin/Eval.hs

@@ -44,7 +44,7 @@ import           Development.IDE.Types.Location (toNormalizedFilePath',
                                                  uriToFilePath')
 import           DynamicLoading                 (initializePlugins)
 import           DynFlags                       (targetPlatform)
-import           GHC                            (DynFlags, ExecResult (..), GeneralFlag (Opt_IgnoreHpcChanges, Opt_IgnoreOptimChanges, Opt_ImplicitImportQualified),
+import           GHC                            (TcRnExprMode(..), DynFlags, ExecResult (..), GeneralFlag (Opt_IgnoreHpcChanges, Opt_IgnoreOptimChanges, Opt_ImplicitImportQualified),
                                                  GhcLink (LinkInMemory),
                                                  GhcMode (CompManager),
                                                  HscTarget (HscInterpreted),
@@ -87,7 +87,11 @@ import           Control.DeepSeq                ( NFData
                                                 , deepseq
                                                 )
 import Outputable (Outputable(ppr), showSDoc)
-import Control.Applicative ((<|>))
+import Data.Char (isSpace)
+import Control.Arrow (Arrow(second))
+import GHC (Ghc)
+import Type.Reflection (Typeable)
+import GHC (exprType)
 
 descriptor :: PluginId -> PluginDescriptor
 descriptor plId =
@@ -247,18 +251,8 @@ done, we want to switch back to GhcSessionDeps:
 
     df <- liftIO $ evalGhcEnv hscEnv' getSessionDynFlags
     let eval (stmt, l)
-          | let stmt0 = T.strip $ T.pack stmt -- For stripping and de-prefixing
-          , Just (reduce, type_) <-
-                  (True,) <$> T.stripPrefix ":kind! " stmt0
-              <|> (False,) <$> T.stripPrefix ":kind " stmt0
-          = do
-            let input = T.strip type_
-            (ty, kind) <- typeKind reduce $ T.unpack input
-            pure $ Just
-              $ T.unlines 
-              $ map ("-- " <>)
-              $ (input <> " :: " <> T.pack (showSDoc df $ ppr kind))
-              : [ "= " <> T.pack (showSDoc df $ ppr ty) | reduce]
+          | Just (cmd, arg) <- parseGhciLikeCmd $ T.pack stmt
+          = evalGhciLikeCmd cmd arg
           | isStmt df stmt = do
             -- set up a custom interactive print function
             liftIO $ writeFile temp ""
@@ -309,6 +303,54 @@ done, we want to switch back to GhcSessionDeps:
 
     return (WorkspaceApplyEdit, ApplyWorkspaceEditParams workspaceEdits)
 
+evalGhciLikeCmd :: Text -> Text -> Ghc (Maybe Text)
+evalGhciLikeCmd cmd arg = do
+  df <- getSessionDynFlags
+  let tppr = T.pack . showSDoc df . ppr
+  case cmd of
+    "kind" -> do
+      let input = T.strip arg
+      (_, kind) <- typeKind False $ T.unpack input
+      pure $ Just $ "-- " <> input <> " :: " <> tppr kind <> "\n"
+    "kind!" -> do
+      let input = T.strip arg
+      (ty, kind) <- typeKind True $ T.unpack input
+      pure
+        $ Just
+        $ T.unlines 
+        $ map ("-- " <>)
+        [ input <> " :: " <> tppr kind
+        , "= " <> tppr ty
+        ]  
+    "type" -> do
+      let (emod, expr) = parseExprMode arg
+      ty <- exprType emod $ T.unpack expr
+      pure $ Just $ 
+        "-- " <> expr <> " :: " <> tppr ty <> "\n"
+    _ -> E.throw $ GhciLikeCmdNotImplemented cmd arg
+
+parseExprMode :: Text -> (TcRnExprMode, T.Text)
+parseExprMode rawArg =
+  case T.break isSpace rawArg of
+    ("+v", rest) -> (TM_NoInst, T.strip rest)
+    ("+d", rest) -> (TM_Default, T.strip rest)
+    _ -> (TM_Inst, rawArg)
+
+data GhciLikeCmdException = GhciLikeCmdNotImplemented Text Text
+  deriving (Typeable)
+
+instance Show GhciLikeCmdException where
+  showsPrec _ (GhciLikeCmdNotImplemented cmd _arg) =
+    showString "unknown command '" .
+    showString (T.unpack cmd) . showChar '\''
+
+instance E.Exception GhciLikeCmdException
+
+parseGhciLikeCmd :: Text -> Maybe (Text, Text)
+parseGhciLikeCmd input = do
+  (':', rest) <- T.uncons $ T.stripStart input
+  pure $ second T.strip $ T.break isSpace rest
+
 strictTry :: NFData b => IO b -> IO (Either String b)
 strictTry op = E.catch
   (op >>= \v -> return $! Right $! deepseq v v)

test/functional/Eval.hs

@@ -70,6 +70,18 @@ tests = testGroup
   , testCase "Shows a kind with :kind" $ goldenTest "T12.hs"
   , testCase "Reports an error for an incorrect type with :kind" 
     $ goldenTest "T13.hs"
+  , testCase "Returns a fully-instantiated type for :type"
+    $ goldenTest "T14.hs"
+  , testCase "Returns an uninstantiated type for :type +v, admitting multiple whitespaces around arguments"
+    $ goldenTest "T15.hs"
+  , testCase "Returns defaulted type for :type +d, admitting multiple whitespaces around arguments"
+    $ goldenTest "T16.hs"
+  , testCase ":type reports an error when given with unknown +x option"
+    $ goldenTest "T17.hs"
+  , testCase "Reports an error when given with unknown command"
+    $ goldenTest "T18.hs"
+  , testCase "Returns defaulted type for :type +d reflecting the default declaration specified in the >>> prompt"
+    $ goldenTest "T19.hs"
   ]
 
 goldenTest :: FilePath -> IO ()

test/testdata/eval/T14.hs

@@ -0,0 +1,7 @@
+{-# LANGUAGE TypeApplications #-}
+module T14 where
+
+foo :: Show a => a -> String
+foo = show
+
+-- >>> :type foo @Int

test/testdata/eval/T14.hs.expected

@@ -0,0 +1,8 @@
+{-# LANGUAGE TypeApplications #-}
+module T14 where
+
+foo :: Show a => a -> String
+foo = show
+
+-- >>> :type foo @Int
+-- foo @Int :: Int -> String

test/testdata/eval/T15.hs

@@ -0,0 +1,7 @@
+{-# LANGUAGE TypeApplications #-}
+module T15 where
+
+foo :: Show a => a -> String
+foo = show
+
+-- >>> :type  +v  foo @Int

test/testdata/eval/T15.hs.expected

@@ -0,0 +1,8 @@
+{-# LANGUAGE TypeApplications #-}
+module T15 where
+
+foo :: Show a => a -> String
+foo = show
+
+-- >>> :type  +v  foo @Int
+-- foo @Int :: Show Int => Int -> String

test/testdata/eval/T16.hs

@@ -0,0 +1,3 @@
+module T16 where
+
+-- >>> :type  +d   40+ 2 

test/testdata/eval/T16.hs.expected

@@ -0,0 +1,4 @@
+module T16 where
+
+-- >>> :type  +d   40+ 2 
+-- 40+ 2 :: Integer

test/testdata/eval/T17.hs

@@ -0,0 +1,3 @@
+module T17 where
+
+-- >>> :type  +no 42

test/testdata/eval/T17.hs.expected

@@ -0,0 +1,4 @@
+module T17 where
+
+-- >>> :type  +no 42
+-- parse error on input ‘+’

test/testdata/eval/T18.hs

@@ -0,0 +1,4 @@
+{-# LANGUAGE TypeApplications #-}
+module T18 where
+
+-- >>> :noooop foo bar

test/testdata/eval/T18.hs.expected

@@ -0,0 +1,5 @@
+{-# LANGUAGE TypeApplications #-}
+module T18 where
+
+-- >>> :noooop foo bar
+-- unknown command 'noooop'

test/testdata/eval/T19.hs

@@ -0,0 +1,6 @@
+module T19 where
+import Data.Word (Word)
+type W = Word
+
+-- >>> default (Word)
+-- >>> :type  +d   40+ 2 

test/testdata/eval/T19.hs.expected

@@ -0,0 +1,7 @@
+module T19 where
+import Data.Word (Word)
+type W = Word
+
+-- >>> default (Word)
+-- >>> :type  +d   40+ 2 
+-- 40+ 2 :: Word