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

src/Ide/Plugin/Eval.hs

@@ -21,6 +21,11 @@
 --    [1] - https://github.com/jyp/dante
 module Ide.Plugin.Eval where
 
+import           Control.Arrow                  (second)
+import qualified Control.Exception             as E
+import           Control.DeepSeq                ( NFData
+                                                , deepseq
+                                                )
 import           Control.Monad                  (void)
 import           Control.Monad.IO.Class         (MonadIO (liftIO))
 import           Control.Monad.Trans.Class      (MonadTrans (lift))
@@ -29,7 +34,9 @@ import           Control.Monad.Trans.Except     (ExceptT (..), runExceptT,
 import           Data.Aeson                     (FromJSON, ToJSON, Value (Null),
                                                  toJSON)
 import           Data.Bifunctor                 (Bifunctor (first))
+import           Data.Char                      (isSpace)
 import qualified Data.HashMap.Strict            as Map
+import           Data.Maybe                     (catMaybes)
 import           Data.String                    (IsString (fromString))
 import           Data.Text                      (Text)
 import qualified Data.Text                      as T
@@ -44,14 +51,15 @@ 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                            (Ghc, TcRnExprMode(..), DynFlags, ExecResult (..), GeneralFlag (Opt_IgnoreHpcChanges, Opt_IgnoreOptimChanges, Opt_ImplicitImportQualified),
                                                  GhcLink (LinkInMemory),
                                                  GhcMode (CompManager),
                                                  HscTarget (HscInterpreted),
                                                  LoadHowMuch (LoadAllTargets),
                                                  SuccessFlag (..),
                                                  execLineNumber, execOptions,
                                                  execSourceFile, execStmt,
+                                                 exprType,
                                                  getContext,
                                                  getInteractiveDynFlags,
                                                  getSession, getSessionDynFlags,
@@ -77,17 +85,12 @@ import           Ide.Types
 import           Language.Haskell.LSP.Core      (LspFuncs (getVirtualFileFunc))
 import           Language.Haskell.LSP.Types
 import           Language.Haskell.LSP.VFS       (virtualFileText)
+import           Outputable (ppr, showSDoc)
 import           PrelNames                      (pRELUDE)
 import           System.FilePath
 import           System.IO                      (hClose)
 import           System.IO.Temp
-import Data.Maybe (catMaybes)
-import qualified Control.Exception             as E
-import           Control.DeepSeq                ( NFData
-                                                , deepseq
-                                                )
-import Outputable (Outputable(ppr), showSDoc)
-import Control.Applicative ((<|>))
+import           Type.Reflection               (Typeable)
 
 descriptor :: PluginId -> PluginDescriptor
 descriptor plId =
@@ -247,18 +250,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 +302,58 @@ 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
+      { ghciCmdName :: Text
+      , ghciCmdArg  :: Text
+      }
+  deriving (Typeable)
+
+instance Show GhciLikeCmdException where
+  showsPrec _ GhciLikeCmdNotImplemented{..} =
+    showString "unknown command '" .
+    showString (T.unpack ghciCmdName) . 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

@@ -25,6 +25,7 @@ import           Language.Haskell.LSP.Types     ( ApplyWorkspaceEditRequest
 import           System.FilePath
 import           Test.Hls.Util
 import           Test.Tasty
+import           Test.Tasty.ExpectedFailure (expectFailBecause)
 import           Test.Tasty.HUnit
 
 tests :: TestTree
@@ -70,6 +71,21 @@ 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"
+  , expectFailBecause "known issue - see a note in P.R. #361"
+  $ testCase ":type +d reflects the `default' declaration of the module"
+  $ goldenTest "T20.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

test/testdata/eval/T20.hs

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

test/testdata/eval/T20.hs.expected

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