Eval plugin: proper multilined results handling and command-name abbreviations

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,71 @@ runEvalCmd lsp state EvalParams {..} = withIndefiniteProgress lsp "Eval" Cancell
 
     return (WorkspaceApplyEdit, ApplyWorkspaceEditParams workspaceEdits)
 
+
+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 -> 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.unlines
+    $ map ("-- " <>)
+    $ T.lines (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.unlines
+    $ map ("-- " <>)
+    $ T.lines
+    $ 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.unlines
+      $ map ("-- " <>)
+      $ T.lines$ 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

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 ()

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

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 -> ()

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

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

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

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 -> ()

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)))))))))))))