Only show linear arrows on datacons with LinearTypes

Author: crtschin

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

@@ -52,12 +52,13 @@ getAtPoint file pos = runMaybeT $ do
   shakeExtras <- lift askShake
 
   env <- hscEnv . fst <$> useWithStaleFastMT GhcSession file
+  parsedModule <- fst <$> useWithStaleFastMT GetParsedModule file
   dkMap <- lift $ maybe (DKMap mempty mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap file)
 
   !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' parsedModule
 
 -- | 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

@@ -41,7 +41,9 @@ import           Development.IDE.Core.PositionMapping
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.GHC.Compat
 import qualified Development.IDE.GHC.Compat.Util      as Util
-import           Development.IDE.GHC.Util             (printOutputable,
+import           Development.IDE.GHC.Util             (getExtensions,
+                                                       getExtensionsSet,
+                                                       printOutputable,
                                                        printOutputableOneLine)
 import           Development.IDE.Spans.Common
 import           Development.IDE.Types.Options
@@ -69,9 +71,12 @@ import qualified Data.Set                             as S
 import           Data.Tree
 import qualified Data.Tree                            as T
 import           Data.Version                         (showVersion)
+import           Debug.Trace                          (traceShow, traceShowId)
 import           Development.IDE.Core.LookupMod       (LookupModule, lookupMod)
+import           Development.IDE.Core.PluginUtils     (runActionE)
 import           Development.IDE.Core.Shake           (ShakeExtras (..),
-                                                       runIdeAction)
+                                                       runIdeAction, use,
+                                                       useWithStaleFast)
 import           Development.IDE.Types.Shake          (WithHieDb)
 import           GHC.Iface.Ext.Types                  (EvVarSource (..),
                                                        HieAST (..),
@@ -261,8 +266,9 @@ atPoint
   -> DocAndTyThingMap
   -> HscEnv
   -> Position
+  -> ParsedModule
   -> 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 parsedModule =
     listToMaybe <$> sequence (pointCommand hf pos hoverInfo)
   where
     -- Hover info for values/data
@@ -282,6 +288,9 @@ atPoint opts@IdeOptions{} shakeExtras@ShakeExtras{ withHieDb, hiedbWriter } har@
         prettyNames <- mapM (prettyName locationsMap) names
         pure (Just range, prettyNames ++ pTypes locationsMap)
       where
+        enabledExtensions :: Util.EnumSet Extension
+        enabledExtensions = getExtensionsSet $ parsedModule
+
         pTypes :: M.Map Name Location -> [T.Text]
         pTypes locationsMap =
           case names of
@@ -318,7 +327,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(..)
@@ -39,22 +38,18 @@ import           Language.LSP.Protocol.Types
 type DocMap = NameEnv SpanDoc
 type TyThingMap = NameEnv TyThing
 type ArgDocMap = NameEnv (IntMap SpanDoc)
+data A = A Word Bool
 
 -- | Shows IEWrappedName, without any modifier, qualifier or unique identifier.
 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