diff --git a/src/Ide/Plugin/Eval.hs b/src/Ide/Plugin/Eval.hs index 1d1372deda..9f779841b3 100644 --- a/src/Ide/Plugin/Eval.hs +++ b/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,7 +51,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 (Ghc, TcRnExprMode(..), DynFlags, ExecResult (..), GeneralFlag (Opt_IgnoreHpcChanges, Opt_IgnoreOptimChanges, Opt_ImplicitImportQualified), GhcLink (LinkInMemory), GhcMode (CompManager), HscTarget (HscInterpreted), @@ -52,6 +59,7 @@ import GHC (DynFlags, ExecResult (..), Gene 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) diff --git a/test/functional/Eval.hs b/test/functional/Eval.hs index 0f99057867..f5351d9a12 100644 --- a/test/functional/Eval.hs +++ b/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 () diff --git a/test/testdata/eval/T14.hs b/test/testdata/eval/T14.hs new file mode 100644 index 0000000000..8f74911c22 --- /dev/null +++ b/test/testdata/eval/T14.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeApplications #-} +module T14 where + +foo :: Show a => a -> String +foo = show + +-- >>> :type foo @Int diff --git a/test/testdata/eval/T14.hs.expected b/test/testdata/eval/T14.hs.expected new file mode 100644 index 0000000000..544679bfff --- /dev/null +++ b/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 diff --git a/test/testdata/eval/T15.hs b/test/testdata/eval/T15.hs new file mode 100644 index 0000000000..684333fbbd --- /dev/null +++ b/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 diff --git a/test/testdata/eval/T15.hs.expected b/test/testdata/eval/T15.hs.expected new file mode 100644 index 0000000000..54f0f38ef5 --- /dev/null +++ b/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 diff --git a/test/testdata/eval/T16.hs b/test/testdata/eval/T16.hs new file mode 100644 index 0000000000..69a43028d1 --- /dev/null +++ b/test/testdata/eval/T16.hs @@ -0,0 +1,3 @@ +module T16 where + +-- >>> :type +d 40+ 2 diff --git a/test/testdata/eval/T16.hs.expected b/test/testdata/eval/T16.hs.expected new file mode 100644 index 0000000000..3edb5b2cc1 --- /dev/null +++ b/test/testdata/eval/T16.hs.expected @@ -0,0 +1,4 @@ +module T16 where + +-- >>> :type +d 40+ 2 +-- 40+ 2 :: Integer diff --git a/test/testdata/eval/T17.hs b/test/testdata/eval/T17.hs new file mode 100644 index 0000000000..0b6d1a9611 --- /dev/null +++ b/test/testdata/eval/T17.hs @@ -0,0 +1,3 @@ +module T17 where + +-- >>> :type +no 42 diff --git a/test/testdata/eval/T17.hs.expected b/test/testdata/eval/T17.hs.expected new file mode 100644 index 0000000000..14e2aa74a1 --- /dev/null +++ b/test/testdata/eval/T17.hs.expected @@ -0,0 +1,4 @@ +module T17 where + +-- >>> :type +no 42 +-- parse error on input ‘+’ diff --git a/test/testdata/eval/T18.hs b/test/testdata/eval/T18.hs new file mode 100644 index 0000000000..42bc0b3e2f --- /dev/null +++ b/test/testdata/eval/T18.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TypeApplications #-} +module T18 where + +-- >>> :noooop foo bar diff --git a/test/testdata/eval/T18.hs.expected b/test/testdata/eval/T18.hs.expected new file mode 100644 index 0000000000..39e72343f1 --- /dev/null +++ b/test/testdata/eval/T18.hs.expected @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeApplications #-} +module T18 where + +-- >>> :noooop foo bar +-- unknown command 'noooop' diff --git a/test/testdata/eval/T19.hs b/test/testdata/eval/T19.hs new file mode 100644 index 0000000000..e58af97967 --- /dev/null +++ b/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 diff --git a/test/testdata/eval/T19.hs.expected b/test/testdata/eval/T19.hs.expected new file mode 100644 index 0000000000..5d5f4ed4c1 --- /dev/null +++ b/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 diff --git a/test/testdata/eval/T20.hs b/test/testdata/eval/T20.hs new file mode 100644 index 0000000000..bd46606ae0 --- /dev/null +++ b/test/testdata/eval/T20.hs @@ -0,0 +1,6 @@ +module T20 where +import Data.Word (Word) + +default (Word) + +-- >>> :type +d 40+ 2 diff --git a/test/testdata/eval/T20.hs.expected b/test/testdata/eval/T20.hs.expected new file mode 100644 index 0000000000..18d2155560 --- /dev/null +++ b/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