Only show linear arrows on data constructors with LinearTypes

ghcide-test/data/hover/Constructors.hs

@@ -0,0 +1,8 @@
+module Constructors where
+
+data A = A
+data B = B Int Word Bool
+data C = C ![Int] {-# UNPACK #-} !Bool
+data D = D { da :: Int, db :: Bool }
+data E = E { ea :: !Int, eb :: {-# UNPACK #-} ![Bool] }
+newtype F = F Int

ghcide-test/data/hover/ConstructorsLinear.hs

@@ -0,0 +1,9 @@
+{-# LANGUAGE LinearTypes #-}
+module ConstructorsLinear where
+
+data A = A
+data B = B Int Word Bool
+data C = C ![Int] {-# UNPACK #-} !Bool
+data D = D { da :: Int, db :: Bool }
+data E = E { ea :: !Int, eb :: {-# UNPACK #-} ![Bool] }
+newtype F = F Int

ghcide-test/data/hover/hie.yaml

@@ -1 +1 @@
-cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax", "GotoImplementation"]}}
+cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax", "GotoImplementation", "Constructors", "ConstructorsLinear"]}}

ghcide-test/exe/ConstructorHoverTests.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ConstructorHoverTests (tests) where
+
+import           Config
+import           Hover
+import           Test.Hls
+import           Test.Hls.FileSystem (copyDir)
+
+tests :: TestTree
+tests =
+    testGroup
+        "constructor hover (#2904)"
+        [ testGroup
+            "Constructors.hs"
+            [ test "A" "Constructors.hs" (Position 2 9) [ExpectHoverText ["A :: A"]]
+            , test "B" "Constructors.hs" (Position 3 9) [ExpectHoverText ["B :: Int -> Word -> Bool -> B"], ExpectHoverExcludeText ["%1 ->"]]
+            , test "C" "Constructors.hs" (Position 4 9) [ExpectHoverText ["C :: [Int] -> Bool -> C"], ExpectHoverExcludeText ["%1 ->"]]
+            , test "D" "Constructors.hs" (Position 5 9) [ExpectHoverText ["D :: Int -> Bool -> D"], ExpectHoverExcludeText ["%1 ->"]]
+            , test "E" "Constructors.hs" (Position 6 9) [ExpectHoverText ["E :: Int -> [Bool] -> E"], ExpectHoverExcludeText ["%1 ->"]]
+            , test "F" "Constructors.hs" (Position 7 12) [ExpectHoverText ["F :: Int -> F"], ExpectHoverExcludeText ["%1 ->"]]
+            ]
+        , testGroup
+            "ConstructorsLinear.hs"
+            [ test "A" "ConstructorsLinear.hs" (Position 3 9) [ExpectHoverText ["A :: A"]]
+            , test "B" "ConstructorsLinear.hs" (Position 4 9) [ExpectHoverText ["B :: Int %1 -> Word %1 -> Bool %1 -> B"]]
+            , test "C" "ConstructorsLinear.hs" (Position 5 9) [ExpectHoverText ["C :: [Int] %1 -> Bool %1 -> C"]]
+            , test "D" "ConstructorsLinear.hs" (Position 6 9) [ExpectHoverText ["D :: Int %1 -> Bool %1 -> D"]]
+            , test "E" "ConstructorsLinear.hs" (Position 7 9) [ExpectHoverText ["E :: Int %1 -> [Bool] %1 -> E"]]
+            , test "F" "ConstructorsLinear.hs" (Position 8 12) [ExpectHoverText ["F :: Int %1 -> F"]]
+            ]
+        ]
+
+test :: String -> FilePath -> Position -> [Expect] -> TestTree
+test title fileName pos expectations =
+    testWithDummyPlugin title (mkIdeTestFs [copyDir "hover"]) $ do
+        doc <- openDoc fileName "haskell"
+        waitForProgressDone
+        hover <- getHover doc pos
+        checkHover hover expectations

ghcide-test/exe/FindDefinitionAndHoverTests.hs

@@ -17,6 +17,7 @@ import           Control.Category           ((>>>))
 import           Control.Lens               ((^.))
 import           Development.IDE.Test       (expectDiagnostics,
                                              standardizeQuotes)
+import           Hover
 import           Test.Hls
 import           Test.Hls.FileSystem        (copyDir)
 import           Text.Regex.TDFA            ((=~))
@@ -91,16 +92,6 @@ tests = let
         "expected: " <> show ("[...]" <> sourceFileName <> ":<LINE>:<COL>**[...]", Just expectedRange) <>
         "\n but got: " <> show (msg, rangeInHover)
 
-  assertFoundIn :: T.Text -> T.Text -> Assertion
-  assertFoundIn part whole = assertBool
-    (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole)
-    (part `T.isInfixOf` whole)
-
-  assertNotFoundIn :: T.Text -> T.Text -> Assertion
-  assertNotFoundIn part whole = assertBool
-    (T.unpack $ "found unexpected: `" <> part <> "` in hover message:\n" <> whole)
-    (not . T.isInfixOf part $ whole)
-
   sourceFilePath = T.unpack sourceFileName
   sourceFileName = "GotoHover.hs"
 

ghcide-test/exe/FindImplementationAndHoverTests.hs

@@ -14,6 +14,7 @@ import           Text.Regex.TDFA      ((=~))
 
 import           Config
 import           Development.IDE.Test (standardizeQuotes)
+import           Hover
 import           Test.Hls
 import           Test.Hls.FileSystem  (copyDir)
 
@@ -47,16 +48,6 @@ tests = let
             _ -> pure () -- all other expectations not relevant to hover
         _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover
 
-  assertFoundIn :: T.Text -> T.Text -> Assertion
-  assertFoundIn part whole = assertBool
-    (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole)
-    (part `T.isInfixOf` whole)
-
-  assertNotFoundIn :: T.Text -> T.Text -> Assertion
-  assertNotFoundIn part whole = assertBool
-    (T.unpack $ "found unexpected: `" <> part <> "` in hover message:\n" <> whole)
-    (not . T.isInfixOf part $ whole)
-
   sourceFilePath = T.unpack sourceFileName
   sourceFileName = "GotoImplementation.hs"
 

ghcide-test/exe/Hover.hs

@@ -0,0 +1,40 @@
+module Hover where
+
+import           Config
+import           Control.Monad
+import           Data.Foldable
+import qualified Data.Text            as T
+import           Development.IDE.Test
+import           Test.Hls
+import           Text.Regex.TDFA
+
+assertFoundIn :: T.Text -> T.Text -> Assertion
+assertFoundIn part whole =
+    assertBool
+        (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole)
+        (part `T.isInfixOf` whole)
+
+assertNotFoundIn :: T.Text -> T.Text -> Assertion
+assertNotFoundIn part whole =
+    assertBool
+        (T.unpack $ "found unexpected: `" <> part <> "` in hover message:\n" <> whole)
+        (not . T.isInfixOf part $ whole)
+
+checkHover :: (HasCallStack) => Maybe Hover -> [Expect] -> Session ()
+checkHover hover expectations = traverse_ check expectations
+  where
+    check :: (HasCallStack) => Expect -> Session ()
+    check expected =
+      case hover of
+        Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"
+        Just Hover{_contents = (InL MarkupContent{_value = standardizeQuotes -> msg})
+                  ,_range    = _rangeInHover } ->
+          case expected of
+            ExpectRange  _expectedRange -> liftIO $ assertFailure $ "ExpectRange assertion not implemented, yet."
+            ExpectHoverRange _expectedRange -> liftIO $ assertFailure $ "ExpectHoverRange assertion not implemented, yet."
+            ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets
+            ExpectHoverExcludeText snippets -> liftIO $ traverse_ (`assertNotFoundIn` msg) snippets
+            ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool)
+            ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover
+            _ -> pure () -- all other expectations not relevant to hover
+        _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover

ghcide-test/exe/Main.hs

@@ -39,6 +39,7 @@ import           BootTests
 import           ClientSettingsTests
 import           CodeLensTests
 import           CompletionTests
+import           ConstructorHoverTests
 import           CPPTests
 import           CradleTests
 import           DependentFileTest
@@ -79,6 +80,7 @@ main = do
     , CodeLensTests.tests
     , OutlineTests.tests
     , HighlightTests.tests
+    , ConstructorHoverTests.tests
     , FindDefinitionAndHoverTests.tests
     , FindImplementationAndHoverTests.tests
     , PluginSimpleTests.tests

ghcide/src/Development/IDE/Core/Actions.hs

@@ -24,6 +24,8 @@ import           Development.IDE.Core.PositionMapping
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Service
 import           Development.IDE.Core.Shake
+import           Development.IDE.GHC.Compat           (DynFlags (..),
+                                                       ms_hspp_opts)
 import           Development.IDE.Graph
 import qualified Development.IDE.Spans.AtPoint        as AtPoint
 import           Development.IDE.Types.HscEnvEq       (hscEnv)
@@ -52,12 +54,14 @@ getAtPoint file pos = runMaybeT $ do
   shakeExtras <- lift askShake
 
   env <- hscEnv . fst <$> useWithStaleFastMT GhcSession file
+  modSummary <- fst <$> useWithStaleFastMT GetModSummary file
   dkMap <- lift $ maybe (DKMap mempty mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap file)
+  let enabledExtensions = extensionFlags (ms_hspp_opts (msrModSummary modSummary))
 
   !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
 
   MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$>
-    AtPoint.atPoint opts shakeExtras hf dkMap env pos'
+    AtPoint.atPoint opts shakeExtras hf dkMap env pos' enabledExtensions
 
 -- | Converts locations in the source code to their current positions,
 -- taking into account changes that may have occurred due to edits.

ghcide/src/Development/IDE/GHC/Compat/Util.hs

@@ -31,6 +31,7 @@ module Development.IDE.GHC.Compat.Util (
     Pair(..),
     -- * EnumSet
     EnumSet,
+    member,
     toList,
     -- * FastString exports
     FastString,

ghcide/src/Development/IDE/GHC/Util.hs

@@ -29,6 +29,7 @@ module Development.IDE.GHC.Util(
     printOutputable,
     printOutputableOneLine,
     getExtensions,
+    getExtensionsSet,
     stripOccNamePrefix,
     ) where
 
@@ -279,7 +280,10 @@ printOutputable' print =
 {-# INLINE printOutputable #-}
 
 getExtensions :: ParsedModule -> [Extension]
-getExtensions = toList . extensionFlags . ms_hspp_opts . pm_mod_summary
+getExtensions = toList . getExtensionsSet
+
+getExtensionsSet :: ParsedModule -> EnumSet Extension
+getExtensionsSet = extensionFlags . ms_hspp_opts . pm_mod_summary
 
 -- | When e.g. DuplicateRecordFields is enabled, compiler generates
 -- names like "$sel:accessor:One" and "$sel:accessor:Two" to
@@ -331,4 +335,3 @@ occNamePrefixes =
   , "$c"
   , "$m"
   ]
-

ghcide/src/Development/IDE/Plugin/Completions.hs

@@ -139,9 +139,9 @@ resolveCompletion ide _pid comp@CompletionItem{_detail,_documentation,_data_} ur
       Nothing -> liftIO $ spanDocToMarkdown . fst <$> getDocumentationTryGhc (hscEnv sess) name
     typ <- case lookupNameEnv km name of
       _ | not needType -> pure Nothing
-      Just ty -> pure (safeTyThingType ty)
+      Just ty -> pure (safeTyThingType True ty)
       Nothing -> do
-        (safeTyThingType =<<) <$> liftIO (lookupName (hscEnv sess) name)
+        (safeTyThingType True =<<) <$> liftIO (lookupName (hscEnv sess) name)
     let det1 = case typ of
           Just ty -> Just (":: " <> printOutputable (stripForall ty) <> "\n")
           Nothing -> Nothing

ghcide/src/Development/IDE/Spans/AtPoint.hs

@@ -261,8 +261,9 @@ atPoint
   -> DocAndTyThingMap
   -> HscEnv
   -> Position
+  -> Util.EnumSet Extension
   -> IO (Maybe (Maybe Range, [T.Text]))
-atPoint opts@IdeOptions{} shakeExtras@ShakeExtras{ withHieDb, hiedbWriter } har@(HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (DKMap dm km _am) env pos =
+atPoint opts@IdeOptions{} shakeExtras@ShakeExtras{ withHieDb, hiedbWriter } har@(HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (DKMap dm km _am) env pos enabledExtensions =
     listToMaybe <$> sequence (pointCommand hf pos hoverInfo)
   where
     -- Hover info for values/data
@@ -318,7 +319,7 @@ atPoint opts@IdeOptions{} shakeExtras@ShakeExtras{ withHieDb, hiedbWriter } har@
             let
               typeSig = case identType dets of
                 Just t -> prettyType (Just n) locationsMap t
-                Nothing -> case safeTyThingType =<< lookupNameEnv km n of
+                Nothing -> case safeTyThingType (Util.member LinearTypes enabledExtensions) =<< lookupNameEnv km n of
                   Just kind -> prettyTypeFromType (Just n) locationsMap kind
                   Nothing   -> wrapHaskell (printOutputable n)
               definitionLoc = maybeToList (pretty (definedAt n) (prettyPackageName n))

ghcide/src/Development/IDE/Spans/Common.hs

@@ -4,7 +4,6 @@
 
 module Development.IDE.Spans.Common (
   unqualIEWrapName
-, safeTyThingId
 , safeTyThingType
 , SpanDoc(..)
 , SpanDocUris(..)
@@ -44,17 +43,12 @@ type ArgDocMap = NameEnv (IntMap SpanDoc)
 unqualIEWrapName :: IEWrappedName GhcPs -> T.Text
 unqualIEWrapName = printOutputable . rdrNameOcc . ieWrappedName
 
--- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs
-safeTyThingType :: TyThing -> Maybe Type
-safeTyThingType thing
-  | Just i <- safeTyThingId thing = Just (varType i)
-safeTyThingType (ATyCon tycon)    = Just (tyConKind tycon)
-safeTyThingType _                 = Nothing
-
-safeTyThingId :: TyThing -> Maybe Id
-safeTyThingId (AnId i)                         = Just i
-safeTyThingId (AConLike (RealDataCon dataCon)) = Just (dataConWrapId dataCon)
-safeTyThingId _                                = Nothing
+safeTyThingType :: Bool -> TyThing -> Maybe Type
+safeTyThingType showLinearType (AConLike (RealDataCon dataCon))
+                                    = Just (dataConDisplayType showLinearType dataCon)
+safeTyThingType _ (AnId i)          = Just (varType i)
+safeTyThingType _ (ATyCon tycon)    = Just (tyConKind tycon)
+safeTyThingType _ _                 = Nothing
 
 -- Possible documentation for an element in the code
 data SpanDoc

haskell-language-server.cabal

@@ -2146,6 +2146,7 @@ test-suite ghcide-tests
     ClientSettingsTests
     CodeLensTests
     CompletionTests
+    ConstructorHoverTests
     CPPTests
     CradleTests
     DependentFileTest
@@ -2158,6 +2159,7 @@ test-suite ghcide-tests
     HaddockTests
     HieDbRetry
     HighlightTests
+    Hover
     IfaceTests
     InitializeResponseTests
     LogType