diff --git a/plugins/default/src/Ide/Plugin/Eval.hs b/plugins/default/src/Ide/Plugin/Eval.hs index 604f5b8d51..f59650b0f6 100644 --- a/plugins/default/src/Ide/Plugin/Eval.hs +++ b/plugins/default/src/Ide/Plugin/Eval.hs @@ -21,69 +21,66 @@ -- [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)) -import Control.Monad.Trans.Except (ExceptT (..), runExceptT, - throwE) -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 -import Data.Time (getCurrentTime) +import Control.Applicative (Alternative ((<|>))) +import Control.Arrow (second) +import Control.DeepSeq (NFData, deepseq) +import qualified Control.Exception as E +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE) +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.List (find) +import Data.Maybe (catMaybes) +import Data.String (IsString (fromString)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (getCurrentTime) import Development.IDE -import DynamicLoading (initializePlugins) -import DynFlags (targetPlatform) -import Development.IDE.GHC.Compat (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, - ghcLink, ghcMode, hscTarget, - isImport, isStmt, load, - moduleName, packageFlags, - parseImportDecl, pkgDatabase, - pkgState, runDecls, setContext, - setInteractiveDynFlags, - setLogAction, - setSessionDynFlags, setTargets, - simpleImportDecl, typeKind, ways) -import GHC.Generics (Generic) -import GhcMonad (modifySession) -import GhcPlugins (defaultLogActionHPutStrDoc, - gopt_set, gopt_unset, - interpWays, updateWays, - wayGeneralFlags, - wayUnsetGeneralFlags) +import Development.IDE.GHC.Compat (DynFlags, ExecResult (..), GeneralFlag (Opt_IgnoreHpcChanges, Opt_IgnoreOptimChanges, Opt_ImplicitImportQualified), + Ghc, GhcLink (LinkInMemory), + GhcMode (CompManager), + HscTarget (HscInterpreted), + LoadHowMuch (LoadAllTargets), + SuccessFlag (..), + TcRnExprMode (..), execLineNumber, + execOptions, execSourceFile, + execStmt, exprType, getContext, + getInteractiveDynFlags, getSession, + getSessionDynFlags, ghcLink, + ghcMode, hscTarget, isImport, + isStmt, load, moduleName, + packageFlags, parseImportDecl, + pkgDatabase, pkgState, runDecls, + setContext, setInteractiveDynFlags, + setLogAction, setSessionDynFlags, + setTargets, simpleImportDecl, + typeKind, ways) +import DynamicLoading (initializePlugins) +import DynFlags (targetPlatform) +import GHC.Generics (Generic) +import GhcMonad (modifySession) +import GhcPlugins (defaultLogActionHPutStrDoc, + gopt_set, gopt_unset, interpWays, + updateWays, wayGeneralFlags, + wayUnsetGeneralFlags) import HscTypes import Ide.Plugin import Ide.Types import Language.Haskell.LSP.Core import Language.Haskell.LSP.Types -import Language.Haskell.LSP.VFS (virtualFileText) -import Outputable (ppr, showSDoc) -import PrelNames (pRELUDE) +import Language.Haskell.LSP.VFS (virtualFileText) +import Outputable (nest, ppr, showSDoc, text, ($$), + (<+>)) +import PrelNames (pRELUDE) import System.FilePath -import System.IO (hClose) +import System.IO (hClose) import System.IO.Temp -import Type.Reflection (Typeable) +import Type.Reflection (Typeable) descriptor :: PluginId -> PluginDescriptor descriptor plId = @@ -280,38 +277,66 @@ runEvalCmd lsp state EvalParams {..} = withIndefiniteProgress lsp "Eval" Cancell return (WorkspaceApplyEdit, ApplyWorkspaceEditParams workspaceEdits) +-- | Resulting @Text@ MUST NOT prefix each line with @--@ +-- Such comment-related post-process will be taken place +-- solely in 'evalGhciLikeCmd'. +type GHCiLikeCmd = DynFlags -> Text -> Ghc (Maybe Text) + +-- Should we use some sort of trie here? +ghciLikeCommands :: [(Text, GHCiLikeCmd)] +ghciLikeCommands = + [ ("kind", doKindCmd False) + , ("kind!", doKindCmd True) + , ("type", doTypeCmd) + ] + 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 + case lookup cmd ghciLikeCommands + <|> snd <$> find (T.isPrefixOf cmd . fst) ghciLikeCommands of + Just hndler -> + fmap + (T.unlines . map ("-- " <>) . T.lines + ) + <$> hndler df arg + _ -> E.throw $ GhciLikeCmdNotImplemented cmd arg + +doKindCmd :: Bool -> DynFlags -> Text -> Ghc (Maybe Text) +doKindCmd False df arg = do + let input = T.strip arg + (_, kind) <- typeKind False $ T.unpack input + let kindText = text (T.unpack input) <+> "::" <+> ppr kind + pure $ Just $ T.pack (showSDoc df kindText) +doKindCmd True df arg = do + let input = T.strip arg + (ty, kind) <- typeKind True $ T.unpack input + let kindDoc = text (T.unpack input) <+> "::" <+> ppr kind + tyDoc = "=" <+> ppr ty + pure $ Just $ T.pack (showSDoc df $ kindDoc $$ tyDoc) + +doTypeCmd :: DynFlags -> Text -> Ghc (Maybe Text) +doTypeCmd dflags arg = do + let (emod, expr) = parseExprMode arg + ty <- exprType emod $ T.unpack expr + let rawType = T.strip $ T.pack $ showSDoc dflags $ ppr ty + broken = T.any (\c -> c == '\r' || c == '\n') rawType + pure $ Just $ + if broken + then T.pack + $ showSDoc dflags + $ text (T.unpack expr) $$ + (nest 2 $ + "::" <+> ppr ty + ) + else expr <> " :: " <> rawType <> "\n" 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) + _ -> (TM_Inst, rawArg) data GhciLikeCmdException = GhciLikeCmdNotImplemented diff --git a/test/functional/Eval.hs b/test/functional/Eval.hs index f5351d9a12..a196ee0485 100644 --- a/test/functional/Eval.hs +++ b/test/functional/Eval.hs @@ -7,25 +7,17 @@ module Eval ) where -import Control.Applicative.Combinators - ( skipManyTill ) -import Control.Monad.IO.Class ( MonadIO(liftIO) ) -import qualified Data.Text.IO as T +import Control.Applicative.Combinators (skipManyTill) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import qualified Data.Text.IO as T import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types ( ApplyWorkspaceEditRequest - , CodeLens - ( CodeLens - , _command - , _range - ) - , Command(_title) - , Position(..) - , Range(..) - ) +import Language.Haskell.LSP.Types (ApplyWorkspaceEditRequest, CodeLens (CodeLens, _command, _range), + Command (_title), + Position (..), Range (..)) import System.FilePath import Test.Hls.Util import Test.Tasty -import Test.Tasty.ExpectedFailure (expectFailBecause) +import Test.Tasty.ExpectedFailure (expectFailBecause) import Test.Tasty.HUnit tests :: TestTree @@ -66,10 +58,10 @@ tests = testGroup , testCase "Evaluate incorrect expressions" $ goldenTest "T8.hs" , testCase "Applies file LANGUAGE extensions" $ goldenTest "T9.hs" , testCase "Evaluate a type with :kind!" $ goldenTest "T10.hs" - , testCase "Reports an error for an incorrect type with :kind!" + , testCase "Reports an error for an incorrect type with :kind!" $ goldenTest "T11.hs" , testCase "Shows a kind with :kind" $ goldenTest "T12.hs" - , testCase "Reports an error for an incorrect type with :kind" + , testCase "Reports an error for an incorrect type with :kind" $ goldenTest "T13.hs" , testCase "Returns a fully-instantiated type for :type" $ goldenTest "T14.hs" @@ -86,6 +78,16 @@ tests = testGroup , expectFailBecause "known issue - see a note in P.R. #361" $ testCase ":type +d reflects the `default' declaration of the module" $ goldenTest "T20.hs" + , testCase ":type handles a multilined result properly" + $ goldenTest "T21.hs" + , testCase ":t behaves exactly the same as :type" + $ goldenTest "T22.hs" + , testCase ":type does \"dovetails\" for short identifiers" + $ goldenTest "T23.hs" + , testCase ":kind! treats a multilined result properly" + $ goldenTest "T24.hs" + , testCase ":kind treats a multilined result properly" + $ goldenTest "T25.hs" ] goldenTest :: FilePath -> IO () diff --git a/test/testdata/eval/T21.hs b/test/testdata/eval/T21.hs new file mode 100644 index 0000000000..0570b8d36e --- /dev/null +++ b/test/testdata/eval/T21.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +module T21 where +import Data.Proxy (Proxy(..)) +import GHC.TypeNats (KnownNat) +import Type.Reflection (Typeable) + +fun :: forall k n a. (KnownNat k, KnownNat n, Typeable a) + => Proxy k -> Proxy n -> Proxy a -> () +fun _ _ _ = () + +-- >>> :type fun diff --git a/test/testdata/eval/T21.hs.expected b/test/testdata/eval/T21.hs.expected new file mode 100644 index 0000000000..5ffcc3906d --- /dev/null +++ b/test/testdata/eval/T21.hs.expected @@ -0,0 +1,16 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +module T21 where +import Data.Proxy (Proxy(..)) +import GHC.TypeNats (KnownNat) +import Type.Reflection (Typeable) + +fun :: forall k n a. (KnownNat k, KnownNat n, Typeable a) + => Proxy k -> Proxy n -> Proxy a -> () +fun _ _ _ = () + +-- >>> :type fun +-- fun +-- :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1). +-- (KnownNat k2, KnownNat n, Typeable a) => +-- Proxy k2 -> Proxy n -> Proxy a -> () diff --git a/test/testdata/eval/T22.hs b/test/testdata/eval/T22.hs new file mode 100644 index 0000000000..43bb32e839 --- /dev/null +++ b/test/testdata/eval/T22.hs @@ -0,0 +1,9 @@ +module T22 where +import Data.Proxy (Proxy (..)) +import GHC.TypeNats (KnownNat) +import Type.Reflection (Typeable) + +f :: Integer +f = 32 + +-- >>> :t f diff --git a/test/testdata/eval/T22.hs.expected b/test/testdata/eval/T22.hs.expected new file mode 100644 index 0000000000..98792c637f --- /dev/null +++ b/test/testdata/eval/T22.hs.expected @@ -0,0 +1,10 @@ +module T22 where +import Data.Proxy (Proxy (..)) +import GHC.TypeNats (KnownNat) +import Type.Reflection (Typeable) + +f :: Integer +f = 32 + +-- >>> :t f +-- f :: Integer diff --git a/test/testdata/eval/T23.hs b/test/testdata/eval/T23.hs new file mode 100644 index 0000000000..6f9c73a12e --- /dev/null +++ b/test/testdata/eval/T23.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +module T23 where +import Data.Proxy (Proxy (..)) +import GHC.TypeNats (KnownNat) +import Type.Reflection (Typeable) + +f :: forall k n a. (KnownNat k, KnownNat n, Typeable a) + => Proxy k -> Proxy n -> Proxy a -> () +f _ _ _ = () + +-- >>> :type f diff --git a/test/testdata/eval/T23.hs.expected b/test/testdata/eval/T23.hs.expected new file mode 100644 index 0000000000..3039ca8a8c --- /dev/null +++ b/test/testdata/eval/T23.hs.expected @@ -0,0 +1,15 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +module T23 where +import Data.Proxy (Proxy (..)) +import GHC.TypeNats (KnownNat) +import Type.Reflection (Typeable) + +f :: forall k n a. (KnownNat k, KnownNat n, Typeable a) + => Proxy k -> Proxy n -> Proxy a -> () +f _ _ _ = () + +-- >>> :type f +-- f :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1). +-- (KnownNat k2, KnownNat n, Typeable a) => +-- Proxy k2 -> Proxy n -> Proxy a -> () diff --git a/test/testdata/eval/T24.hs b/test/testdata/eval/T24.hs new file mode 100644 index 0000000000..01f53ed17d --- /dev/null +++ b/test/testdata/eval/T24.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module T24 where +import GHC.TypeNats (type (-)) +data Proxy a = Stop | Next (Proxy a) + +type family LongP n a where + LongP 0 a = a + LongP n a = Next (LongP (n - 1) a) + +-- >>> :kind! ((LongP 10 Stop) :: Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy Double))))))))))))) diff --git a/test/testdata/eval/T24.hs.expected b/test/testdata/eval/T24.hs.expected new file mode 100644 index 0000000000..f7909ddb04 --- /dev/null +++ b/test/testdata/eval/T24.hs.expected @@ -0,0 +1,32 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module T24 where +import GHC.TypeNats (type (-)) +data Proxy a = Stop | Next (Proxy a) + +type family LongP n a where + LongP 0 a = a + LongP n a = Next (LongP (n - 1) a) + +-- >>> :kind! ((LongP 10 Stop) :: Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy Double))))))))))))) +-- ((LongP 10 Stop) :: Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy Double))))))))))))) :: Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- Double)))))))))))) +-- = 'Next +-- ('Next +-- ('Next +-- ('Next ('Next ('Next ('Next ('Next ('Next ('Next 'Stop))))))))) diff --git a/test/testdata/eval/T25.hs b/test/testdata/eval/T25.hs new file mode 100644 index 0000000000..e813d207db --- /dev/null +++ b/test/testdata/eval/T25.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module T25 where +import GHC.TypeNats (type (-)) +data Proxy a = Stop | Next (Proxy a) + +type family LongP n a where + LongP 0 a = a + LongP n a = Next (LongP (n - 1) a) + +-- >>> :kind (Stop :: Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy Double))))))))))))) diff --git a/test/testdata/eval/T25.hs.expected b/test/testdata/eval/T25.hs.expected new file mode 100644 index 0000000000..1b85e9ae56 --- /dev/null +++ b/test/testdata/eval/T25.hs.expected @@ -0,0 +1,28 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module T25 where +import GHC.TypeNats (type (-)) +data Proxy a = Stop | Next (Proxy a) + +type family LongP n a where + LongP 0 a = a + LongP n a = Next (LongP (n - 1) a) + +-- >>> :kind (Stop :: Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy Double))))))))))))) +-- (Stop :: Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy Double))))))))))))) :: Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- Double))))))))))))