From fb3eb460c8fd7971e24639b19e07d70402aa5968 Mon Sep 17 00:00:00 2001 From: fendor Date: Wed, 17 Apr 2019 17:06:04 +0200 Subject: [PATCH 01/16] Change TypeMap implementation --- .../Haskell/Ide/Engine/ArtifactMap.hs | 10 -- .../Haskell/Ide/Engine/ModuleCache.hs | 1 + hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs | 166 ++++++++++++++++++ hie-plugin-api/hie-plugin-api.cabal | 1 + 4 files changed, 168 insertions(+), 10 deletions(-) create mode 100644 hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs diff --git a/hie-plugin-api/Haskell/Ide/Engine/ArtifactMap.hs b/hie-plugin-api/Haskell/Ide/Engine/ArtifactMap.hs index 4225e4298..8e45e6a6c 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/ArtifactMap.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/ArtifactMap.hs @@ -10,7 +10,6 @@ import GHC (TypecheckedModule) import qualified SrcLoc as GHC import qualified Var import qualified GhcMod.Gap as GM -import GhcMod.SrcUtils import Language.Haskell.LSP.Types @@ -33,15 +32,6 @@ genIntervalMap ts = foldr go IM.empty ts -- --------------------------------------------------------------------- -genTypeMap :: GHC.GhcMonad m => TypecheckedModule -> m TypeMap -genTypeMap tm = do - ts <- collectAllSpansTypes True tm - return $ foldr go IM.empty ts - where - go (GHC.RealSrcSpan spn, typ) im = - IM.insert (rspToInt spn) typ im - go _ im = im - -- | Generates a LocMap from a TypecheckedModule, -- which allows fast queries for all the symbols -- located at a particular point in the source diff --git a/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs b/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs index c5baa0d7a..0fcfa27d9 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs @@ -42,6 +42,7 @@ import qualified GhcMod.Utils as GM import qualified GHC as GHC import Haskell.Ide.Engine.ArtifactMap +import Haskell.Ide.Engine.TypeMap import Haskell.Ide.Engine.GhcModuleCache import Haskell.Ide.Engine.MultiThreadState import Haskell.Ide.Engine.PluginsIdeMonads diff --git a/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs b/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs new file mode 100644 index 000000000..e2faa7ee2 --- /dev/null +++ b/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} +module Haskell.Ide.Engine.TypeMap where + +import qualified Data.IntervalMap.FingerTree as IM + +import qualified GHC +import GHC ( TypecheckedModule ) +import GhcMod.SrcUtils + +import Data.Data as Data +import Control.Monad.IO.Class +import Data.Maybe +import qualified TcHsSyn +import qualified TysWiredIn +import qualified CoreUtils +import qualified Type +import qualified Desugar + +import Haskell.Ide.Engine.ArtifactMap + +genTypeMap :: GHC.GhcMonad m => TypecheckedModule -> m TypeMap +genTypeMap tm = do + let typecheckedSource = GHC.tm_typechecked_source tm + hs_env <- GHC.getSession + liftIO $ types hs_env typecheckedSource + +collectAllSpansTypes' + :: GHC.GhcMonad m => Bool -> TypecheckedModule -> m [(GHC.SrcSpan, GHC.Type)] +collectAllSpansTypes' = collectAllSpansTypes + +-- | Obtain details map for types. +types :: GHC.HscEnv -> GHC.TypecheckedSource -> IO TypeMap +types hs_env = everythingInTypecheckedSourceM (ty `combineM` fun) + where + ty :: forall a . Data a => a -> IO TypeMap + ty term = case cast term of + (Just lhsExprGhc@(GHC.L (GHC.RealSrcSpan spn) _)) -> + getType hs_env lhsExprGhc >>= \case + Nothing -> return IM.empty + Just (_, typ) -> return (IM.singleton (rspToInt spn) typ) + _ -> return IM.empty + + fun :: forall a . Data a => a -> IO TypeMap + fun term = case cast term of + (Just (GHC.L (GHC.RealSrcSpan spn) hsPatType)) -> + return (IM.singleton (rspToInt spn) (TcHsSyn.hsPatType hsPatType)) + _ -> return IM.empty + + +everythingInTypecheckedSourceM + :: Data x + => (forall a . Data a => a -> IO TypeMap) + -> x + -> IO TypeMap +everythingInTypecheckedSourceM f = everythingButTypeM @GHC.Name f + +-- | Combine two queries into one using alternative combinator. +combineM + :: (forall a. Data a => a -> IO TypeMap) + -> (forall a. Data a => a -> IO TypeMap) + -> (forall a. Data a => a -> IO TypeMap) +combineM f g x = do + a <- f x + b <- g x + return (a `IM.union` b) + +-- | Variation of "everything" that does not recurse into children of type t +-- requires AllowAmbiguousTypes +everythingButTypeM + :: forall t + . (Typeable t) + => (forall a . Data a => a -> IO TypeMap) + -> (forall a . Data a => a -> IO TypeMap) +everythingButTypeM f = everythingButM $ (,) <$> f <*> isType @t + +-- | Returns true if a == t. +-- requires AllowAmbiguousTypes +isType :: forall a b . (Typeable a, Typeable b) => b -> Bool +isType _ = isJust $ eqT @a @b + +-- | Variation of "everything" with an added stop condition +-- Just like 'everything', this is stolen from SYB package. +everythingButM + :: (forall a . Data a => a -> (IO TypeMap, Bool)) + -> (forall a . Data a => a -> IO TypeMap) +everythingButM f x = do + let (v, stop) = f x + if stop + then v + else Data.gmapQr + (\e acc -> do + e' <- e + a <- acc + return (e' `IM.union` a) + ) + v + (everythingButM f) + x + +-- | This instance tries to construct 'HieAST' nodes which include the type of +-- the expression. It is not yet possible to do this efficiently for all +-- expression forms, so we skip filling in the type for those inputs. +-- +-- 'HsApp', for example, doesn't have any type information available directly on +-- the node. Our next recourse would be to desugar it into a 'CoreExpr' then +-- query the type of that. Yet both the desugaring call and the type query both +-- involve recursive calls to the function and argument! This is particularly +-- problematic when you realize that the HIE traversal will eventually visit +-- those nodes too and ask for their types again. +-- +-- Since the above is quite costly, we just skip cases where computing the +-- expression's type is going to be expensive. +-- +-- See #16233 +getType + :: GHC.HscEnv -> GHC.LHsExpr GHC.GhcTc -> IO (Maybe (GHC.SrcSpan, Type.Type)) +getType hs_env e@(GHC.L spn e') = + -- Some expression forms have their type immediately available + let + tyOpt = case e' of + GHC.HsLit _ l -> Just (TcHsSyn.hsLitType l) + GHC.HsOverLit _ o -> Just (GHC.overLitType o) + + GHC.HsLam _ GHC.MG { GHC.mg_ext = groupTy } -> + Just (matchGroupType groupTy) + GHC.HsLamCase _ GHC.MG { GHC.mg_ext = groupTy } -> + Just (matchGroupType groupTy) + GHC.HsCase _ _ GHC.MG { GHC.mg_ext = groupTy } -> + Just (GHC.mg_res_ty groupTy) + + GHC.ExplicitList ty _ _ -> Just (TysWiredIn.mkListTy ty) + GHC.ExplicitSum ty _ _ _ -> Just (TysWiredIn.mkSumTy ty) + GHC.HsDo ty _ _ -> Just ty + GHC.HsMultiIf ty _ -> Just ty + + _ -> Nothing + in case tyOpt of + _ + | skipDesugaring e' -> pure Nothing + | otherwise -> do + (_, mbe) <- Desugar.deSugarExpr hs_env e + let res = (spn, ) . CoreUtils.exprType <$> mbe + pure res + where + matchGroupType :: GHC.MatchGroupTc -> GHC.Type + matchGroupType (GHC.MatchGroupTc args res) = Type.mkFunTys args res + -- | Skip desugaring of these expressions for performance reasons. + -- + -- See impact on Haddock output (esp. missing type annotations or links) + -- before marking more things here as 'False'. See impact on Haddock + -- performance before marking more things as 'True'. + skipDesugaring :: GHC.HsExpr a -> Bool + skipDesugaring expression = case expression of + GHC.HsVar{} -> False + GHC.HsUnboundVar{} -> False + GHC.HsConLikeOut{} -> False + GHC.HsRecFld{} -> False + GHC.HsOverLabel{} -> False + GHC.HsIPVar{} -> False + GHC.HsWrap{} -> False + _ -> True diff --git a/hie-plugin-api/hie-plugin-api.cabal b/hie-plugin-api/hie-plugin-api.cabal index 4a30f8144..0cfa53308 100644 --- a/hie-plugin-api/hie-plugin-api.cabal +++ b/hie-plugin-api/hie-plugin-api.cabal @@ -29,6 +29,7 @@ library Haskell.Ide.Engine.MultiThreadState Haskell.Ide.Engine.PluginsIdeMonads Haskell.Ide.Engine.PluginUtils + Haskell.Ide.Engine.TypeMap build-depends: base >= 4.9 && < 5 , Diff , aeson From ea5f819a78cfa8c4411513259348420cb5705776 Mon Sep 17 00:00:00 2001 From: fendor Date: Wed, 17 Apr 2019 17:32:29 +0200 Subject: [PATCH 02/16] Replace GHC.Name with GHC.Id in genTypeMap --- hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs b/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs index e2faa7ee2..5cfd416ae 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs @@ -57,7 +57,7 @@ everythingInTypecheckedSourceM => (forall a . Data a => a -> IO TypeMap) -> x -> IO TypeMap -everythingInTypecheckedSourceM f = everythingButTypeM @GHC.Name f +everythingInTypecheckedSourceM f = everythingButTypeM @GHC.Id f -- | Combine two queries into one using alternative combinator. combineM From 11bbe7fb53b1c28ff00c678d6ac646f3fde7cead Mon Sep 17 00:00:00 2001 From: fendor Date: Sun, 21 Apr 2019 22:28:12 +0200 Subject: [PATCH 03/16] Add comment --- hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs | 21 ++++++++++---------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs b/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs index 5cfd416ae..98c88ff13 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs @@ -23,10 +23,12 @@ import qualified Desugar import Haskell.Ide.Engine.ArtifactMap +-- | Generate a mapping from an Interval to types. +-- Intervals may overlap and return more specific results. genTypeMap :: GHC.GhcMonad m => TypecheckedModule -> m TypeMap genTypeMap tm = do let typecheckedSource = GHC.tm_typechecked_source tm - hs_env <- GHC.getSession + hs_env <- GHC.getSession liftIO $ types hs_env typecheckedSource collectAllSpansTypes' @@ -40,8 +42,8 @@ types hs_env = everythingInTypecheckedSourceM (ty `combineM` fun) ty :: forall a . Data a => a -> IO TypeMap ty term = case cast term of (Just lhsExprGhc@(GHC.L (GHC.RealSrcSpan spn) _)) -> - getType hs_env lhsExprGhc >>= \case - Nothing -> return IM.empty + getType hs_env lhsExprGhc >>= \case + Nothing -> return IM.empty Just (_, typ) -> return (IM.singleton (rspToInt spn) typ) _ -> return IM.empty @@ -53,18 +55,15 @@ types hs_env = everythingInTypecheckedSourceM (ty `combineM` fun) everythingInTypecheckedSourceM - :: Data x - => (forall a . Data a => a -> IO TypeMap) - -> x - -> IO TypeMap + :: Data x => (forall a . Data a => a -> IO TypeMap) -> x -> IO TypeMap everythingInTypecheckedSourceM f = everythingButTypeM @GHC.Id f -- | Combine two queries into one using alternative combinator. combineM - :: (forall a. Data a => a -> IO TypeMap) - -> (forall a. Data a => a -> IO TypeMap) - -> (forall a. Data a => a -> IO TypeMap) -combineM f g x = do + :: (forall a . Data a => a -> IO TypeMap) + -> (forall a . Data a => a -> IO TypeMap) + -> (forall a . Data a => a -> IO TypeMap) +combineM f g x = do a <- f x b <- g x return (a `IM.union` b) From 1805ebb06d1227f041f26095128a2e1028d25533 Mon Sep 17 00:00:00 2001 From: fendor Date: Wed, 24 Apr 2019 18:17:27 +0200 Subject: [PATCH 04/16] Remove unused function and add comment --- hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs b/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs index 98c88ff13..9e835aeaa 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs @@ -10,7 +10,6 @@ import qualified Data.IntervalMap.FingerTree as IM import qualified GHC import GHC ( TypecheckedModule ) -import GhcMod.SrcUtils import Data.Data as Data import Control.Monad.IO.Class @@ -31,9 +30,11 @@ genTypeMap tm = do hs_env <- GHC.getSession liftIO $ types hs_env typecheckedSource -collectAllSpansTypes' - :: GHC.GhcMonad m => Bool -> TypecheckedModule -> m [(GHC.SrcSpan, GHC.Type)] -collectAllSpansTypes' = collectAllSpansTypes + +everythingInTypecheckedSourceM + :: Data x => (forall a . Data a => a -> IO TypeMap) -> x -> IO TypeMap +everythingInTypecheckedSourceM = everythingButTypeM @GHC.Id + -- | Obtain details map for types. types :: GHC.HscEnv -> GHC.TypecheckedSource -> IO TypeMap @@ -53,11 +54,6 @@ types hs_env = everythingInTypecheckedSourceM (ty `combineM` fun) return (IM.singleton (rspToInt spn) (TcHsSyn.hsPatType hsPatType)) _ -> return IM.empty - -everythingInTypecheckedSourceM - :: Data x => (forall a . Data a => a -> IO TypeMap) -> x -> IO TypeMap -everythingInTypecheckedSourceM f = everythingButTypeM @GHC.Id f - -- | Combine two queries into one using alternative combinator. combineM :: (forall a . Data a => a -> IO TypeMap) @@ -115,7 +111,7 @@ everythingButM f x = do -- Since the above is quite costly, we just skip cases where computing the -- expression's type is going to be expensive. -- --- See #16233 +-- See #16233 getType :: GHC.HscEnv -> GHC.LHsExpr GHC.GhcTc -> IO (Maybe (GHC.SrcSpan, Type.Type)) getType hs_env e@(GHC.L spn e') = From aaa6968ee6b392c20fc74d9fbf82fb526d2f8eb2 Mon Sep 17 00:00:00 2001 From: fendor Date: Thu, 25 Apr 2019 20:39:50 +0200 Subject: [PATCH 05/16] Add Pattern Synonyms for GHC 8.6.4 --- hie-plugin-api/Haskell/Ide/Engine/Compat.hs | 40 ++++++++++++++++++++ hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs | 26 +++++-------- 2 files changed, 49 insertions(+), 17 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Compat.hs b/hie-plugin-api/Haskell/Ide/Engine/Compat.hs index 756dab9bd..1df422da8 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Compat.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Compat.hs @@ -1,6 +1,14 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} module Haskell.Ide.Engine.Compat where + +import qualified GHC +import qualified Type +import qualified TcHsSyn +import qualified TysWiredIn + #if MIN_VERSION_filepath(1,4,2) #else import Data.List @@ -27,3 +35,35 @@ isExtensionOf :: String -> FilePath -> Bool isExtensionOf ext@('.':_) = isSuffixOf ext . takeExtensions isExtensionOf ext = isSuffixOf ('.':ext) . takeExtensions #endif + + +#if MIN_VERSION_ghc(8, 6, 0) + +pattern HsOverLitType :: Type.Type -> GHC.HsExpr GHC.GhcTc +pattern HsOverLitType t <- GHC.HsOverLit _ (GHC.overLitType -> t) + +pattern HsLitType :: Type.Type -> GHC.HsExpr GHC.GhcTc +pattern HsLitType t <- GHC.HsLit _ (TcHsSyn.hsLitType -> t) + +pattern HsLamType :: Type.Type -> GHC.HsExpr GHC.GhcTc +pattern HsLamType t <- GHC.HsLam _ ((\(GHC.MG { GHC.mg_ext = groupTy }) -> matchGroupType groupTy) -> t) + +pattern HsLamCaseType :: Type.Type -> GHC.HsExpr GHC.GhcTc +pattern HsLamCaseType t <- GHC.HsLamCase _ ((\(GHC.MG { GHC.mg_ext = groupTy }) -> matchGroupType groupTy) -> t) + +pattern HsCaseType :: Type.Type -> GHC.HsExpr GHC.GhcTc +pattern HsCaseType t <- GHC.HsCase _ _ ((\(GHC.MG { GHC.mg_ext = groupTy }) -> matchGroupType groupTy) -> t) + +pattern ExplicitListType :: Type.Type -> GHC.HsExpr GHC.GhcTc +pattern ExplicitListType t <- GHC.ExplicitList (TysWiredIn.mkListTy -> t) _ _ + +pattern ExplicitSumType :: Type.Type -> GHC.HsExpr GHC.GhcTc +pattern ExplicitSumType t <- GHC.ExplicitSum (TysWiredIn.mkSumTy -> t) _ _ _ + +pattern HsMultiIfType :: Type.Type -> GHC.HsExpr GHC.GhcTc +pattern HsMultiIfType t <- GHC.HsMultiIf t _ + +matchGroupType :: GHC.MatchGroupTc -> GHC.Type +matchGroupType (GHC.MatchGroupTc args res) = Type.mkFunTys args res + +#endif \ No newline at end of file diff --git a/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs b/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs index 9e835aeaa..e6fc1029b 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs @@ -15,10 +15,10 @@ import Data.Data as Data import Control.Monad.IO.Class import Data.Maybe import qualified TcHsSyn -import qualified TysWiredIn import qualified CoreUtils import qualified Type import qualified Desugar +import Haskell.Ide.Engine.Compat import Haskell.Ide.Engine.ArtifactMap @@ -118,20 +118,14 @@ getType hs_env e@(GHC.L spn e') = -- Some expression forms have their type immediately available let tyOpt = case e' of - GHC.HsLit _ l -> Just (TcHsSyn.hsLitType l) - GHC.HsOverLit _ o -> Just (GHC.overLitType o) - - GHC.HsLam _ GHC.MG { GHC.mg_ext = groupTy } -> - Just (matchGroupType groupTy) - GHC.HsLamCase _ GHC.MG { GHC.mg_ext = groupTy } -> - Just (matchGroupType groupTy) - GHC.HsCase _ _ GHC.MG { GHC.mg_ext = groupTy } -> - Just (GHC.mg_res_ty groupTy) - - GHC.ExplicitList ty _ _ -> Just (TysWiredIn.mkListTy ty) - GHC.ExplicitSum ty _ _ _ -> Just (TysWiredIn.mkSumTy ty) - GHC.HsDo ty _ _ -> Just ty - GHC.HsMultiIf ty _ -> Just ty + HsOverLitType t -> Just t + HsLitType t -> Just t + HsLamType t -> Just t + HsLamCaseType t -> Just t + HsCaseType t -> Just t + ExplicitListType t -> Just t + ExplicitSumType t -> Just t + HsMultiIfType t -> Just t _ -> Nothing in case tyOpt of @@ -142,8 +136,6 @@ getType hs_env e@(GHC.L spn e') = let res = (spn, ) . CoreUtils.exprType <$> mbe pure res where - matchGroupType :: GHC.MatchGroupTc -> GHC.Type - matchGroupType (GHC.MatchGroupTc args res) = Type.mkFunTys args res -- | Skip desugaring of these expressions for performance reasons. -- -- See impact on Haddock output (esp. missing type annotations or links) From 823d35e88d1e8628d5f8c0a31a1c0044891b93e9 Mon Sep 17 00:00:00 2001 From: fendor Date: Fri, 26 Apr 2019 16:16:28 +0200 Subject: [PATCH 06/16] Add support for GHC 8.4.4 and GHC 8.2.2 --- hie-plugin-api/Haskell/Ide/Engine/Compat.hs | 97 ++++++++++++++++---- hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs | 2 +- 2 files changed, 80 insertions(+), 19 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Compat.hs b/hie-plugin-api/Haskell/Ide/Engine/Compat.hs index 1df422da8..d13b4a541 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Compat.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Compat.hs @@ -3,7 +3,6 @@ {-# LANGUAGE ViewPatterns #-} module Haskell.Ide.Engine.Compat where - import qualified GHC import qualified Type import qualified TcHsSyn @@ -37,33 +36,95 @@ isExtensionOf ext = isSuffixOf ('.':ext) . takeExtensions #endif +#if MIN_VERSION_ghc(8, 4, 0) +type GhcTc = GHC.GhcTc +#else +type GhcTc = GHC.Id +#endif + +pattern HsOverLitType :: Type.Type -> GHC.HsExpr GhcTc +pattern HsOverLitType t <- #if MIN_VERSION_ghc(8, 6, 0) + GHC.HsOverLit _ (GHC.overLitType -> t) +#elif MIN_VERSION_ghc(8, 4, 0) + GHC.HsOverLit (GHC.overLitType -> t) +#else + GHC.HsOverLit (GHC.overLitType -> t) +#endif -pattern HsOverLitType :: Type.Type -> GHC.HsExpr GHC.GhcTc -pattern HsOverLitType t <- GHC.HsOverLit _ (GHC.overLitType -> t) +pattern HsLitType :: Type.Type -> GHC.HsExpr GhcTc +pattern HsLitType t <- +#if MIN_VERSION_ghc(8, 6, 0) + GHC.HsLit _ (TcHsSyn.hsLitType -> t) +#elif MIN_VERSION_ghc(8, 4, 0) + GHC.HsLit (TcHsSyn.hsLitType -> t) +#else + GHC.HsLit (TcHsSyn.hsLitType -> t) +#endif -pattern HsLitType :: Type.Type -> GHC.HsExpr GHC.GhcTc -pattern HsLitType t <- GHC.HsLit _ (TcHsSyn.hsLitType -> t) +pattern HsLamType :: Type.Type -> GHC.HsExpr GhcTc +pattern HsLamType t <- +#if MIN_VERSION_ghc(8, 6, 0) + GHC.HsLam _ ((\(GHC.MG { GHC.mg_ext = groupTy }) -> matchGroupType groupTy) -> t) +#elif MIN_VERSION_ghc(8, 4, 0) + GHC.HsLam (\GHC.MG { GHC.mg_res_ty = res, GHC.mg_arg_tys = args } -> Type.mkFunTys args res -> t) +#else + GHC.HsLam (\GHC.MG { GHC.mg_res_ty = res, GHC.mg_arg_tys = args } -> Type.mkFunTys args res -> t) +#endif -pattern HsLamType :: Type.Type -> GHC.HsExpr GHC.GhcTc -pattern HsLamType t <- GHC.HsLam _ ((\(GHC.MG { GHC.mg_ext = groupTy }) -> matchGroupType groupTy) -> t) +pattern HsLamCaseType :: Type.Type -> GHC.HsExpr GhcTc +pattern HsLamCaseType t <- +#if MIN_VERSION_ghc(8, 6, 0) + GHC.HsLamCase _ ((\(GHC.MG { GHC.mg_ext = groupTy }) -> matchGroupType groupTy) -> t) +#elif MIN_VERSION_ghc(8, 4, 0) + GHC.HsLamCase (\GHC.MG { GHC.mg_res_ty = res, GHC.mg_arg_tys = args } -> Type.mkFunTys args res -> t) +#else + GHC.HsLamCase (\GHC.MG { GHC.mg_res_ty = res, GHC.mg_arg_tys = args } -> Type.mkFunTys args res -> t) +#endif -pattern HsLamCaseType :: Type.Type -> GHC.HsExpr GHC.GhcTc -pattern HsLamCaseType t <- GHC.HsLamCase _ ((\(GHC.MG { GHC.mg_ext = groupTy }) -> matchGroupType groupTy) -> t) +pattern HsCaseType :: Type.Type -> GHC.HsExpr GhcTc +pattern HsCaseType t <- +#if MIN_VERSION_ghc(8, 6, 0) + GHC.HsCase _ _ ((\(GHC.MG { GHC.mg_ext = groupTy }) -> matchGroupType groupTy) -> t) +#elif MIN_VERSION_ghc(8, 4, 0) + GHC.HsCase _ (\GHC.MG { GHC.mg_res_ty = res, GHC.mg_arg_tys = args } -> Type.mkFunTys args res -> t) +#else + GHC.HsCase _ (\GHC.MG { GHC.mg_res_ty = res, GHC.mg_arg_tys = args } -> Type.mkFunTys args res -> t) +#endif -pattern HsCaseType :: Type.Type -> GHC.HsExpr GHC.GhcTc -pattern HsCaseType t <- GHC.HsCase _ _ ((\(GHC.MG { GHC.mg_ext = groupTy }) -> matchGroupType groupTy) -> t) +pattern ExplicitListType :: Type.Type -> GHC.HsExpr GhcTc +pattern ExplicitListType t <- +#if MIN_VERSION_ghc(8, 6, 0) + GHC.ExplicitList (TysWiredIn.mkListTy -> t) _ _ +#elif MIN_VERSION_ghc(8, 4, 0) + GHC.ExplicitList (TysWiredIn.mkListTy -> t) _ _ +#else + GHC.ExplicitList (TysWiredIn.mkListTy -> t) _ _ +#endif -pattern ExplicitListType :: Type.Type -> GHC.HsExpr GHC.GhcTc -pattern ExplicitListType t <- GHC.ExplicitList (TysWiredIn.mkListTy -> t) _ _ +pattern ExplicitSumType :: Type.Type -> GHC.HsExpr GhcTc +pattern ExplicitSumType t <- +#if MIN_VERSION_ghc(8, 6, 0) + GHC.ExplicitSum (TysWiredIn.mkSumTy -> t) _ _ _ +#elif MIN_VERSION_ghc(8, 4, 0) + GHC.ExplicitSum _ _ _ (TysWiredIn.mkSumTy -> t) +#else + GHC.ExplicitSum _ _ _ (TysWiredIn.mkSumTy -> t) +#endif -pattern ExplicitSumType :: Type.Type -> GHC.HsExpr GHC.GhcTc -pattern ExplicitSumType t <- GHC.ExplicitSum (TysWiredIn.mkSumTy -> t) _ _ _ -pattern HsMultiIfType :: Type.Type -> GHC.HsExpr GHC.GhcTc -pattern HsMultiIfType t <- GHC.HsMultiIf t _ +pattern HsMultiIfType :: Type.Type -> GHC.HsExpr GhcTc +pattern HsMultiIfType t <- +#if MIN_VERSION_ghc(8, 6, 0) + GHC.HsMultiIf t _ +#elif MIN_VERSION_ghc(8, 4, 0) + GHC.HsMultiIf t _ +#else + GHC.HsMultiIf t _ +#endif +#if MIN_VERSION_ghc(8, 6, 0) matchGroupType :: GHC.MatchGroupTc -> GHC.Type matchGroupType (GHC.MatchGroupTc args res) = Type.mkFunTys args res +#endif -#endif \ No newline at end of file diff --git a/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs b/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs index e6fc1029b..2360d0bb1 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs @@ -113,7 +113,7 @@ everythingButM f x = do -- -- See #16233 getType - :: GHC.HscEnv -> GHC.LHsExpr GHC.GhcTc -> IO (Maybe (GHC.SrcSpan, Type.Type)) + :: GHC.HscEnv -> GHC.LHsExpr GhcTc -> IO (Maybe (GHC.SrcSpan, Type.Type)) getType hs_env e@(GHC.L spn e') = -- Some expression forms have their type immediately available let From 6a7a5b154f81ea893374f5b2eed45e4225861188 Mon Sep 17 00:00:00 2001 From: fendor Date: Fri, 26 Apr 2019 17:06:17 +0200 Subject: [PATCH 07/16] Fix GhcModPluginSpec tests --- test/unit/GhcModPluginSpec.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/test/unit/GhcModPluginSpec.hs b/test/unit/GhcModPluginSpec.hs index 699e4efb8..aaee045ca 100644 --- a/test/unit/GhcModPluginSpec.hs +++ b/test/unit/GhcModPluginSpec.hs @@ -91,8 +91,6 @@ ghcmodSpec = arg = TP False uri (toPos (5,9)) res = IdeResultOk [(Range (toPos (5,9)) (toPos (5,10)), "Int") - ,(Range (toPos (5,9)) (toPos (5,14)), "Int") - ,(Range (toPos (5,1)) (toPos (5,14)), "Int -> Int") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -110,8 +108,6 @@ ghcmodSpec = let arg = TP False uri (toPos (5,9)) let res = IdeResultOk [(Range (toPos (5,9)) (toPos (5,10)), "Int") - ,(Range (toPos (5,9)) (toPos (5,14)), "Int") - ,(Range (toPos (5,1)) (toPos (5,14)), "Int -> Int") ] testCommand testPlugins act "ghcmod" "type" arg res From a81a2651c1cab6560b55d909b963642814548ef9 Mon Sep 17 00:00:00 2001 From: fendor Date: Fri, 26 Apr 2019 17:18:58 +0200 Subject: [PATCH 08/16] Add more tests for type information --- test/unit/GhcModPluginSpec.hs | 23 ++++++++++++++++++++++- 1 file changed, 22 insertions(+), 1 deletion(-) diff --git a/test/unit/GhcModPluginSpec.hs b/test/unit/GhcModPluginSpec.hs index aaee045ca..71ec24a09 100644 --- a/test/unit/GhcModPluginSpec.hs +++ b/test/unit/GhcModPluginSpec.hs @@ -82,7 +82,7 @@ ghcmodSpec = -- --------------------------------- - it "runs the type command" $ withCurrentDirectory "./test/testdata" $ do + it "runs the type command, find type" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "HaReRename.hs" let uri = filePathToUri fp act = do @@ -93,6 +93,27 @@ ghcmodSpec = [(Range (toPos (5,9)) (toPos (5,10)), "Int") ] testCommand testPlugins act "ghcmod" "type" arg res + it "runs the type command, find function type" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "HaReRename.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (2,11)) uri + arg = TP False uri (toPos (2,11)) + res = IdeResultOk + [(Range (toPos (2, 8)) (toPos (2,16)), "String -> IO ()") + ] + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, no type at location" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "HaReRename.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (1,1)) uri + arg = TP False uri (toPos (1,1)) + res = IdeResultOk [] + testCommand testPlugins act "ghcmod" "type" arg res it "runs the type command with an absolute path from another folder, correct params" $ do fp <- makeAbsolute "./test/testdata/HaReRename.hs" From 49822a036f171abb3fe1fac02c4aeef85e3793c9 Mon Sep 17 00:00:00 2001 From: fendor Date: Fri, 26 Apr 2019 19:16:32 +0200 Subject: [PATCH 09/16] Add more tests for the type map impl --- test/testdata/Types.hs | 28 ++++ test/unit/GhcModPluginSpec.hs | 286 ++++++++++++++++++++++++++++++++++ 2 files changed, 314 insertions(+) create mode 100644 test/testdata/Types.hs diff --git a/test/testdata/Types.hs b/test/testdata/Types.hs new file mode 100644 index 000000000..e065b982c --- /dev/null +++ b/test/testdata/Types.hs @@ -0,0 +1,28 @@ +module Types where + +import Control.Applicative + +foo :: Maybe Int -> Int +foo (Just x) = x +foo Nothing = 0 + +bar :: Maybe Int -> Int +bar x = case x of + Just y -> y + 1 + Nothing -> 0 + +maybeMonad :: Maybe Int -> Maybe Int +maybeMonad x = do + y <- x + let z = return (y + 10) + b <- z + return (b + y) + +funcTest :: (a -> a) -> a -> a +funcTest f a = f a + +compTest :: (b -> c) -> (a -> b) -> a -> c +compTest f g = let h = f . g in h + +monadStuff :: (a -> b) -> IO a -> IO b +monadStuff f action = f <$> action \ No newline at end of file diff --git a/test/unit/GhcModPluginSpec.hs b/test/unit/GhcModPluginSpec.hs index 71ec24a09..cdc56e32c 100644 --- a/test/unit/GhcModPluginSpec.hs +++ b/test/unit/GhcModPluginSpec.hs @@ -115,6 +115,292 @@ ghcmodSpec = res = IdeResultOk [] testCommand testPlugins act "ghcmod" "type" arg res +-- ---------------------------------------------------------------------------- + it "runs the type command, simple" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (6,16)) uri + arg = TP False uri (toPos (6,16)) + res = IdeResultOk [(Range (toPos (6, 16)) (toPos (6,17)), "Int")] + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, sum type pattern match, just" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (6,6)) uri + arg = TP False uri (toPos (6, 6)) + res = IdeResultOk + [ (Range (toPos (6, 6)) (toPos (6, 12)), "Maybe Int") + , (Range (toPos (6, 5)) (toPos (6, 13)), "Maybe Int") + -- TODO: why is this happening? + ] + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, sum type pattern match, just value" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (6,11)) uri + arg = TP False uri (toPos (6, 11)) + res = IdeResultOk + [ (Range (toPos (6, 11)) (toPos (6, 12)), "Int") + , (Range (toPos (6, 6)) (toPos (6, 12)), "Maybe Int") + , (Range (toPos (6, 5)) (toPos (6, 13)), "Maybe Int") + -- TODO: why is this happening? + ] + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, sum type pattern match, nothing" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (7,5)) uri + arg = TP False uri (toPos (7,5)) + res = IdeResultOk [(Range (toPos (7, 5)) (toPos (7, 12)), "Maybe Int")] + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, sum type pattern match, nothing, literal" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (7,15)) uri + arg = TP False uri (toPos (7,15)) + res = IdeResultOk [] + -- TODO: do we want this? + --(Range (toPos (7, 15)) (toPos (7, 16)), "Int") + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, variable matching" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (10,5)) uri + arg = TP False uri (toPos (10,5)) + res = IdeResultOk [(Range (toPos (10, 5)) (toPos (10, 6)), "Maybe Int")] + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, case expr" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (10,14)) uri + arg = TP False uri (toPos (10,14)) + res = IdeResultOk [(Range (toPos (10, 14)) (toPos (10, 15)), "Maybe Int")] + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, case expr match, just" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (11,5)) uri + arg = TP False uri (toPos (11,5)) + res = IdeResultOk [(Range (toPos (11, 5)) (toPos (11, 11)), "Maybe Int")] + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, case expr match, just value" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (11,10)) uri + arg = TP False uri (toPos (11,10)) + res = IdeResultOk + [ (Range (toPos (11, 10)) (toPos (11, 11)), "Int") + , (Range (toPos (11, 5)) (toPos (11, 11)), "Maybe Int") + ] + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, infix operator" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (11,17)) uri + arg = TP False uri (toPos (11,17)) + res = IdeResultOk + [ (Range (toPos (11, 17)) (toPos (11, 18)), "Int -> Int -> Int") + ] + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, case expr match, nothing" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (12,5)) uri + arg = TP False uri (toPos (12,5)) + res = IdeResultOk [(Range (toPos (12, 5)) (toPos (12, 12)), "Maybe Int")] + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, do bind expr result " $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (16,5)) uri + arg = TP False uri (toPos (16,5)) + res = IdeResultOk [(Range (toPos (16, 5)) (toPos (16, 6)), "Int")] + testCommand testPlugins act "ghcmod" "type" arg res + it "runs the type command, do bind expr" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (16,10)) uri + arg = TP False uri (toPos (16,10)) + res = IdeResultOk [(Range (toPos (16, 10)) (toPos (16, 11)), "Maybe Int")] + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, let binding function, return func" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (17,13)) uri + arg = TP False uri (toPos (17,13)) + res = IdeResultOk [(Range (toPos (17, 13)) (toPos (17, 19)), "Int -> Maybe Int")] + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, let binding function, return param" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (17,21)) uri + arg = TP False uri (toPos (17,21)) + res = IdeResultOk [(Range (toPos (17, 21)) (toPos (17, 22)), "Int")] + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, let binding function, function type" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (17,9)) uri + arg = TP False uri (toPos (17,9)) + res = IdeResultOk [] + -- TODO: do we want this? + -- (Range (toPos (17, 9)) (toPos (17, 10)), "Maybe Int") + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, do expr, function type" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (18,10)) uri + arg = TP False uri (toPos (18,10)) + res = IdeResultOk [(Range (toPos (18, 10)) (toPos (18, 11)), "Maybe Int")] + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, let binding function, do expr bind for local func" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (18,5)) uri + arg = TP False uri (toPos (18,5)) + res = IdeResultOk [(Range (toPos (18, 5)) (toPos (18, 6)), "Int")] + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, function type" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (15,5)) uri + arg = TP False uri (toPos (15,5)) + res = IdeResultOk [] + -- TODO: the type is known, why not in the map? + -- [(Range (toPos (15, 1)) (toPos (14, 11)), "Maybe Int -> Maybe Int")] + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, function parameter" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (22,10)) uri + arg = TP False uri (toPos (22,10)) + res = IdeResultOk [(Range (toPos (22, 10)) (toPos (22, 11)), "a -> a")] + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, function parameter" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (22,10)) uri + arg = TP False uri (toPos (22,10)) + res = IdeResultOk [(Range (toPos (22, 10)) (toPos (22, 11)), "a -> a")] + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, function composition" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (25,26)) uri + arg = TP False uri (toPos (25,26)) + res = IdeResultOk + [ (Range (toPos (25, 26)) (toPos (25, 27)), "(b -> c) -> (a -> b) -> a -> c") + ] + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, let binding, function composition" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (25,20)) uri + arg = TP False uri (toPos (25,20)) + res = IdeResultOk [] + -- TODO: do we want this? + --(Range (toPos (25, 20)) (toPos (25, 21)), "a -> c") + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, let binding, type of function" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (25,33)) uri + arg = TP False uri (toPos (25,33)) + res = IdeResultOk [(Range (toPos (25, 33)) (toPos (25, 34)), "a -> c")] + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, function type composition" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (25,5)) uri + arg = TP False uri (toPos (25,5)) + res = IdeResultOk [] + -- TODO: the type is known, why not in the map? + -- (Range (toPos (25, 1)) (toPos (25, 9)), "(b -> c) -> (a -> b) -> a -> c") + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, infix operator" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (28,25)) uri + arg = TP False uri (toPos (28,25)) + res = IdeResultOk [(Range (toPos (28, 25)) (toPos (28, 28)), "(a -> b) -> IO a -> IO b")] + testCommand testPlugins act "ghcmod" "type" arg res +-- ---------------------------------------------------------------------------- it "runs the type command with an absolute path from another folder, correct params" $ do fp <- makeAbsolute "./test/testdata/HaReRename.hs" cd <- getCurrentDirectory From 6b655ee3692e01e696570afb2d0f55596e9de2a5 Mon Sep 17 00:00:00 2001 From: fendor Date: Fri, 26 Apr 2019 19:25:08 +0200 Subject: [PATCH 10/16] Update documentation of getType --- hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs | 16 ++++------------ 1 file changed, 4 insertions(+), 12 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs b/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs index 2360d0bb1..b8a53f5df 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs @@ -97,19 +97,11 @@ everythingButM f x = do (everythingButM f) x --- | This instance tries to construct 'HieAST' nodes which include the type of --- the expression. It is not yet possible to do this efficiently for all --- expression forms, so we skip filling in the type for those inputs. +-- | Attempts to get the type for expressions in a lazy and cost saving way. +-- Avoids costly desugaring of Expressions and only obtains the type at the leaf of an expression. -- --- 'HsApp', for example, doesn't have any type information available directly on --- the node. Our next recourse would be to desugar it into a 'CoreExpr' then --- query the type of that. Yet both the desugaring call and the type query both --- involve recursive calls to the function and argument! This is particularly --- problematic when you realize that the HIE traversal will eventually visit --- those nodes too and ask for their types again. --- --- Since the above is quite costly, we just skip cases where computing the --- expression's type is going to be expensive. +-- Implementation is taken from: HieAst.hs +-- Slightly adapted to work for the supported GHC versions 8.2.1 - 8.6.4 -- -- See #16233 getType From 8abb57c8c9e0c4824b9428a724cba03c5c68f486 Mon Sep 17 00:00:00 2001 From: fendor Date: Fri, 26 Apr 2019 20:46:22 +0200 Subject: [PATCH 11/16] Actually pattern match on the results of tyOpt --- hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs b/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs index b8a53f5df..9b24d4756 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs @@ -121,7 +121,8 @@ getType hs_env e@(GHC.L spn e') = _ -> Nothing in case tyOpt of - _ + Just t -> return $ Just (spn ,t) + Nothing | skipDesugaring e' -> pure Nothing | otherwise -> do (_, mbe) <- Desugar.deSugarExpr hs_env e From 81c866e101153790b69408996d846ecec752b0cf Mon Sep 17 00:00:00 2001 From: fendor Date: Fri, 26 Apr 2019 20:46:35 +0200 Subject: [PATCH 12/16] Adapt tests and add tests for deriving clause --- test/testdata/Types.hs | 7 +++- test/unit/GhcModPluginSpec.hs | 64 +++++++++++++++++++++++++++++++---- 2 files changed, 64 insertions(+), 7 deletions(-) diff --git a/test/testdata/Types.hs b/test/testdata/Types.hs index e065b982c..8d6b4338b 100644 --- a/test/testdata/Types.hs +++ b/test/testdata/Types.hs @@ -25,4 +25,9 @@ compTest :: (b -> c) -> (a -> b) -> a -> c compTest f g = let h = f . g in h monadStuff :: (a -> b) -> IO a -> IO b -monadStuff f action = f <$> action \ No newline at end of file +monadStuff f action = f <$> action + +data Test + = TestC Int + | TestM String + deriving (Show, Eq, Ord) \ No newline at end of file diff --git a/test/unit/GhcModPluginSpec.hs b/test/unit/GhcModPluginSpec.hs index cdc56e32c..d36db6647 100644 --- a/test/unit/GhcModPluginSpec.hs +++ b/test/unit/GhcModPluginSpec.hs @@ -172,9 +172,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (7,15)) uri arg = TP False uri (toPos (7,15)) - res = IdeResultOk [] - -- TODO: do we want this? - --(Range (toPos (7, 15)) (toPos (7, 16)), "Int") + res = IdeResultOk [(Range (toPos (7, 15)) (toPos (7, 16)), "Int")] testCommand testPlugins act "ghcmod" "type" arg res it "runs the type command, variable matching" $ withCurrentDirectory "./test/testdata" $ do @@ -194,7 +192,10 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (10,14)) uri arg = TP False uri (toPos (10,14)) - res = IdeResultOk [(Range (toPos (10, 14)) (toPos (10, 15)), "Maybe Int")] + res = IdeResultOk + [ (Range (toPos (10, 14)) (toPos (10, 15)), "Maybe Int") + , (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int") + ] testCommand testPlugins act "ghcmod" "type" arg res it "runs the type command, case expr match, just" $ withCurrentDirectory "./test/testdata" $ do @@ -204,7 +205,10 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (11,5)) uri arg = TP False uri (toPos (11,5)) - res = IdeResultOk [(Range (toPos (11, 5)) (toPos (11, 11)), "Maybe Int")] + res = IdeResultOk + [ (Range (toPos (11, 5)) (toPos (11, 11)), "Maybe Int") + , (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int") + ] testCommand testPlugins act "ghcmod" "type" arg res it "runs the type command, case expr match, just value" $ withCurrentDirectory "./test/testdata" $ do @@ -217,6 +221,7 @@ ghcmodSpec = res = IdeResultOk [ (Range (toPos (11, 10)) (toPos (11, 11)), "Int") , (Range (toPos (11, 5)) (toPos (11, 11)), "Maybe Int") + , (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -229,6 +234,7 @@ ghcmodSpec = arg = TP False uri (toPos (11,17)) res = IdeResultOk [ (Range (toPos (11, 17)) (toPos (11, 18)), "Int -> Int -> Int") + , (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -239,7 +245,10 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (12,5)) uri arg = TP False uri (toPos (12,5)) - res = IdeResultOk [(Range (toPos (12, 5)) (toPos (12, 12)), "Maybe Int")] + res = IdeResultOk + [ (Range (toPos (12, 5)) (toPos (12, 12)), "Maybe Int") + , (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int") + ] testCommand testPlugins act "ghcmod" "type" arg res it "runs the type command, do bind expr result " $ withCurrentDirectory "./test/testdata" $ do @@ -251,6 +260,7 @@ ghcmodSpec = arg = TP False uri (toPos (16,5)) res = IdeResultOk [(Range (toPos (16, 5)) (toPos (16, 6)), "Int")] testCommand testPlugins act "ghcmod" "type" arg res + it "runs the type command, do bind expr" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" let uri = filePathToUri fp @@ -400,6 +410,48 @@ ghcmodSpec = arg = TP False uri (toPos (28,25)) res = IdeResultOk [(Range (toPos (28, 25)) (toPos (28, 28)), "(a -> b) -> IO a -> IO b")] testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, constructor" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (31,7)) uri + arg = TP False uri (toPos (31,7)) + res = IdeResultOk + [ -- (Range (toPos (31, 7)) (toPos (31, 12)), "Int -> Test") + ] + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, deriving clause Show type" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (33,15)) uri + arg = TP False uri (toPos (33,15)) + res = IdeResultOk + [ (Range (toPos (33, 15)) (toPos (33, 19)), "(Int -> Test -> ShowS) -> (Test -> String) -> ([Test] -> ShowS) -> Show Test") + , (Range (toPos (33, 15)) (toPos (33, 19)), "Int -> Test -> ShowS") + , (Range (toPos (33, 15)) (toPos (33, 19)), "Test -> String") + , (Range (toPos (33, 15)) (toPos (33, 19)), "[Test] -> ShowS") + ] + testCommand testPlugins act "ghcmod" "type" arg res + + it "runs the type command, deriving clause Eq type" $ withCurrentDirectory "./test/testdata" $ do + fp <- makeAbsolute "Types.hs" + let uri = filePathToUri fp + act = do + _ <- setTypecheckedModule uri + liftToGhc $ newTypeCmd (toPos (33,21)) uri + arg = TP False uri (toPos (33,21)) + res = IdeResultOk + [ (Range (toPos (33, 21)) (toPos (33, 23)), "(Test -> Test -> Bool) -> (Test -> Test -> Bool) -> Eq Test") + , (Range (toPos (33, 21)) (toPos (33, 23)), "Test -> Test -> Bool") + , (Range (toPos (33, 21)) (toPos (33, 23)), "Test -> Test -> Bool") + ] + testCommand testPlugins act "ghcmod" "type" arg res + -- ---------------------------------------------------------------------------- it "runs the type command with an absolute path from another folder, correct params" $ do fp <- makeAbsolute "./test/testdata/HaReRename.hs" From aec6709e9919579e4da4eb0aa166ae312243ca8f Mon Sep 17 00:00:00 2001 From: fendor Date: Fri, 26 Apr 2019 20:49:21 +0200 Subject: [PATCH 13/16] Reformat tests --- test/unit/GhcModPluginSpec.hs | 56 ++++++++++++++++++++++++++--------- 1 file changed, 42 insertions(+), 14 deletions(-) diff --git a/test/unit/GhcModPluginSpec.hs b/test/unit/GhcModPluginSpec.hs index d36db6647..208e82332 100644 --- a/test/unit/GhcModPluginSpec.hs +++ b/test/unit/GhcModPluginSpec.hs @@ -123,7 +123,9 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (6,16)) uri arg = TP False uri (toPos (6,16)) - res = IdeResultOk [(Range (toPos (6, 16)) (toPos (6,17)), "Int")] + res = IdeResultOk + [ (Range (toPos (6, 16)) (toPos (6,17)), "Int") + ] testCommand testPlugins act "ghcmod" "type" arg res it "runs the type command, sum type pattern match, just" $ withCurrentDirectory "./test/testdata" $ do @@ -162,7 +164,9 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (7,5)) uri arg = TP False uri (toPos (7,5)) - res = IdeResultOk [(Range (toPos (7, 5)) (toPos (7, 12)), "Maybe Int")] + res = IdeResultOk + [ (Range (toPos (7, 5)) (toPos (7, 12)), "Maybe Int") + ] testCommand testPlugins act "ghcmod" "type" arg res it "runs the type command, sum type pattern match, nothing, literal" $ withCurrentDirectory "./test/testdata" $ do @@ -172,7 +176,9 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (7,15)) uri arg = TP False uri (toPos (7,15)) - res = IdeResultOk [(Range (toPos (7, 15)) (toPos (7, 16)), "Int")] + res = IdeResultOk + [ (Range (toPos (7, 15)) (toPos (7, 16)), "Int") + ] testCommand testPlugins act "ghcmod" "type" arg res it "runs the type command, variable matching" $ withCurrentDirectory "./test/testdata" $ do @@ -182,7 +188,9 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (10,5)) uri arg = TP False uri (toPos (10,5)) - res = IdeResultOk [(Range (toPos (10, 5)) (toPos (10, 6)), "Maybe Int")] + res = IdeResultOk + [ (Range (toPos (10, 5)) (toPos (10, 6)), "Maybe Int") + ] testCommand testPlugins act "ghcmod" "type" arg res it "runs the type command, case expr" $ withCurrentDirectory "./test/testdata" $ do @@ -258,7 +266,9 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (16,5)) uri arg = TP False uri (toPos (16,5)) - res = IdeResultOk [(Range (toPos (16, 5)) (toPos (16, 6)), "Int")] + res = IdeResultOk + [ (Range (toPos (16, 5)) (toPos (16, 6)), "Int") + ] testCommand testPlugins act "ghcmod" "type" arg res it "runs the type command, do bind expr" $ withCurrentDirectory "./test/testdata" $ do @@ -268,7 +278,9 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (16,10)) uri arg = TP False uri (toPos (16,10)) - res = IdeResultOk [(Range (toPos (16, 10)) (toPos (16, 11)), "Maybe Int")] + res = IdeResultOk + [ (Range (toPos (16, 10)) (toPos (16, 11)), "Maybe Int") + ] testCommand testPlugins act "ghcmod" "type" arg res it "runs the type command, let binding function, return func" $ withCurrentDirectory "./test/testdata" $ do @@ -278,7 +290,9 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (17,13)) uri arg = TP False uri (toPos (17,13)) - res = IdeResultOk [(Range (toPos (17, 13)) (toPos (17, 19)), "Int -> Maybe Int")] + res = IdeResultOk + [ (Range (toPos (17, 13)) (toPos (17, 19)), "Int -> Maybe Int") + ] testCommand testPlugins act "ghcmod" "type" arg res it "runs the type command, let binding function, return param" $ withCurrentDirectory "./test/testdata" $ do @@ -288,7 +302,9 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (17,21)) uri arg = TP False uri (toPos (17,21)) - res = IdeResultOk [(Range (toPos (17, 21)) (toPos (17, 22)), "Int")] + res = IdeResultOk + [ (Range (toPos (17, 21)) (toPos (17, 22)), "Int") + ] testCommand testPlugins act "ghcmod" "type" arg res it "runs the type command, let binding function, function type" $ withCurrentDirectory "./test/testdata" $ do @@ -310,7 +326,9 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (18,10)) uri arg = TP False uri (toPos (18,10)) - res = IdeResultOk [(Range (toPos (18, 10)) (toPos (18, 11)), "Maybe Int")] + res = IdeResultOk + [ (Range (toPos (18, 10)) (toPos (18, 11)), "Maybe Int") + ] testCommand testPlugins act "ghcmod" "type" arg res it "runs the type command, let binding function, do expr bind for local func" $ withCurrentDirectory "./test/testdata" $ do @@ -320,7 +338,9 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (18,5)) uri arg = TP False uri (toPos (18,5)) - res = IdeResultOk [(Range (toPos (18, 5)) (toPos (18, 6)), "Int")] + res = IdeResultOk + [ (Range (toPos (18, 5)) (toPos (18, 6)), "Int") + ] testCommand testPlugins act "ghcmod" "type" arg res it "runs the type command, function type" $ withCurrentDirectory "./test/testdata" $ do @@ -342,7 +362,9 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (22,10)) uri arg = TP False uri (toPos (22,10)) - res = IdeResultOk [(Range (toPos (22, 10)) (toPos (22, 11)), "a -> a")] + res = IdeResultOk + [ (Range (toPos (22, 10)) (toPos (22, 11)), "a -> a") + ] testCommand testPlugins act "ghcmod" "type" arg res it "runs the type command, function parameter" $ withCurrentDirectory "./test/testdata" $ do @@ -352,7 +374,9 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (22,10)) uri arg = TP False uri (toPos (22,10)) - res = IdeResultOk [(Range (toPos (22, 10)) (toPos (22, 11)), "a -> a")] + res = IdeResultOk + [ (Range (toPos (22, 10)) (toPos (22, 11)), "a -> a") + ] testCommand testPlugins act "ghcmod" "type" arg res it "runs the type command, function composition" $ withCurrentDirectory "./test/testdata" $ do @@ -386,7 +410,9 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (25,33)) uri arg = TP False uri (toPos (25,33)) - res = IdeResultOk [(Range (toPos (25, 33)) (toPos (25, 34)), "a -> c")] + res = IdeResultOk + [ (Range (toPos (25, 33)) (toPos (25, 34)), "a -> c") + ] testCommand testPlugins act "ghcmod" "type" arg res it "runs the type command, function type composition" $ withCurrentDirectory "./test/testdata" $ do @@ -408,7 +434,9 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (28,25)) uri arg = TP False uri (toPos (28,25)) - res = IdeResultOk [(Range (toPos (28, 25)) (toPos (28, 28)), "(a -> b) -> IO a -> IO b")] + res = IdeResultOk + [ (Range (toPos (28, 25)) (toPos (28, 28)), "(a -> b) -> IO a -> IO b") + ] testCommand testPlugins act "ghcmod" "type" arg res it "runs the type command, constructor" $ withCurrentDirectory "./test/testdata" $ do From 91dd4c7beee69104e086b69cac91b4e3108597a8 Mon Sep 17 00:00:00 2001 From: fendor Date: Sat, 27 Apr 2019 15:47:59 +0200 Subject: [PATCH 14/16] Add type information for fun pat --- hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs | 9 ++- test/unit/GhcModPluginSpec.hs | 73 ++++++++++++-------- 2 files changed, 53 insertions(+), 29 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs b/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs index 9b24d4756..b5d00d035 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs @@ -18,6 +18,7 @@ import qualified TcHsSyn import qualified CoreUtils import qualified Type import qualified Desugar +import qualified Var import Haskell.Ide.Engine.Compat import Haskell.Ide.Engine.ArtifactMap @@ -38,7 +39,7 @@ everythingInTypecheckedSourceM = everythingButTypeM @GHC.Id -- | Obtain details map for types. types :: GHC.HscEnv -> GHC.TypecheckedSource -> IO TypeMap -types hs_env = everythingInTypecheckedSourceM (ty `combineM` fun) +types hs_env = everythingInTypecheckedSourceM (ty `combineM` fun `combineM` funBind) where ty :: forall a . Data a => a -> IO TypeMap ty term = case cast term of @@ -54,6 +55,12 @@ types hs_env = everythingInTypecheckedSourceM (ty `combineM` fun) return (IM.singleton (rspToInt spn) (TcHsSyn.hsPatType hsPatType)) _ -> return IM.empty + funBind :: forall a . Data a => a -> IO TypeMap + funBind term = case cast term of + (Just (GHC.L (GHC.RealSrcSpan spn) ((GHC.FunBind _ (GHC.L _ (idp :: GHC.IdP GhcTc)) _ _ _) :: GHC.HsBindLR GhcTc GhcTc))) -> + return (IM.singleton (rspToInt spn) (Var.varType idp)) + _ -> return IM.empty + -- | Combine two queries into one using alternative combinator. combineM :: (forall a . Data a => a -> IO TypeMap) diff --git a/test/unit/GhcModPluginSpec.hs b/test/unit/GhcModPluginSpec.hs index 208e82332..3c40cc1ff 100644 --- a/test/unit/GhcModPluginSpec.hs +++ b/test/unit/GhcModPluginSpec.hs @@ -80,7 +80,7 @@ ghcmodSpec = -- ghc-mod tries to load the test file in the context of the hie project if we do not cd first. testCommand testPlugins act "ghcmod" "info" arg res - -- --------------------------------- +-- ---------------------------------------------------------------------------- it "runs the type command, find type" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "HaReRename.hs" @@ -90,8 +90,10 @@ ghcmodSpec = liftToGhc $ newTypeCmd (toPos (5,9)) uri arg = TP False uri (toPos (5,9)) res = IdeResultOk - [(Range (toPos (5,9)) (toPos (5,10)), "Int") + [ (Range (toPos (5,9)) (toPos (5,10)), "Int") + , (Range (toPos (5,1)) (toPos (5,14)), "Int -> Int") ] + testCommand testPlugins act "ghcmod" "type" arg res it "runs the type command, find function type" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "HaReRename.hs" @@ -101,7 +103,8 @@ ghcmodSpec = liftToGhc $ newTypeCmd (toPos (2,11)) uri arg = TP False uri (toPos (2,11)) res = IdeResultOk - [(Range (toPos (2, 8)) (toPos (2,16)), "String -> IO ()") + [ (Range (toPos (2, 8)) (toPos (2,16)), "String -> IO ()") + , (Range (toPos (2, 1)) (toPos (2,24)), "IO ()") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -115,7 +118,6 @@ ghcmodSpec = res = IdeResultOk [] testCommand testPlugins act "ghcmod" "type" arg res --- ---------------------------------------------------------------------------- it "runs the type command, simple" $ withCurrentDirectory "./test/testdata" $ do fp <- makeAbsolute "Types.hs" let uri = filePathToUri fp @@ -125,6 +127,7 @@ ghcmodSpec = arg = TP False uri (toPos (6,16)) res = IdeResultOk [ (Range (toPos (6, 16)) (toPos (6,17)), "Int") + , (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> Int") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -138,7 +141,7 @@ ghcmodSpec = res = IdeResultOk [ (Range (toPos (6, 6)) (toPos (6, 12)), "Maybe Int") , (Range (toPos (6, 5)) (toPos (6, 13)), "Maybe Int") - -- TODO: why is this happening? + , (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> Int") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -153,7 +156,7 @@ ghcmodSpec = [ (Range (toPos (6, 11)) (toPos (6, 12)), "Int") , (Range (toPos (6, 6)) (toPos (6, 12)), "Maybe Int") , (Range (toPos (6, 5)) (toPos (6, 13)), "Maybe Int") - -- TODO: why is this happening? + , (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> Int") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -166,6 +169,7 @@ ghcmodSpec = arg = TP False uri (toPos (7,5)) res = IdeResultOk [ (Range (toPos (7, 5)) (toPos (7, 12)), "Maybe Int") + , (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> Int") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -178,6 +182,7 @@ ghcmodSpec = arg = TP False uri (toPos (7,15)) res = IdeResultOk [ (Range (toPos (7, 15)) (toPos (7, 16)), "Int") + , (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> Int") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -190,6 +195,7 @@ ghcmodSpec = arg = TP False uri (toPos (10,5)) res = IdeResultOk [ (Range (toPos (10, 5)) (toPos (10, 6)), "Maybe Int") + , (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -203,6 +209,7 @@ ghcmodSpec = res = IdeResultOk [ (Range (toPos (10, 14)) (toPos (10, 15)), "Maybe Int") , (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int") + , (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -216,6 +223,7 @@ ghcmodSpec = res = IdeResultOk [ (Range (toPos (11, 5)) (toPos (11, 11)), "Maybe Int") , (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int") + , (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -230,6 +238,7 @@ ghcmodSpec = [ (Range (toPos (11, 10)) (toPos (11, 11)), "Int") , (Range (toPos (11, 5)) (toPos (11, 11)), "Maybe Int") , (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int") + , (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -243,6 +252,7 @@ ghcmodSpec = res = IdeResultOk [ (Range (toPos (11, 17)) (toPos (11, 18)), "Int -> Int -> Int") , (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int") + , (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -256,6 +266,7 @@ ghcmodSpec = res = IdeResultOk [ (Range (toPos (12, 5)) (toPos (12, 12)), "Maybe Int") , (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int") + , (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -268,6 +279,7 @@ ghcmodSpec = arg = TP False uri (toPos (16,5)) res = IdeResultOk [ (Range (toPos (16, 5)) (toPos (16, 6)), "Int") + , (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -280,6 +292,7 @@ ghcmodSpec = arg = TP False uri (toPos (16,10)) res = IdeResultOk [ (Range (toPos (16, 10)) (toPos (16, 11)), "Maybe Int") + , (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -292,6 +305,8 @@ ghcmodSpec = arg = TP False uri (toPos (17,13)) res = IdeResultOk [ (Range (toPos (17, 13)) (toPos (17, 19)), "Int -> Maybe Int") + , (Range (toPos (17, 9)) (toPos (17, 28)), "Maybe Int") + , (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -304,6 +319,8 @@ ghcmodSpec = arg = TP False uri (toPos (17,21)) res = IdeResultOk [ (Range (toPos (17, 21)) (toPos (17, 22)), "Int") + , (Range (toPos (17, 9)) (toPos (17, 28)), "Maybe Int") + , (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -314,9 +331,10 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (17,9)) uri arg = TP False uri (toPos (17,9)) - res = IdeResultOk [] - -- TODO: do we want this? - -- (Range (toPos (17, 9)) (toPos (17, 10)), "Maybe Int") + res = IdeResultOk + [ (Range (toPos (17, 9)) (toPos (17, 28)), "Maybe Int") + , (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int") + ] testCommand testPlugins act "ghcmod" "type" arg res it "runs the type command, do expr, function type" $ withCurrentDirectory "./test/testdata" $ do @@ -328,6 +346,7 @@ ghcmodSpec = arg = TP False uri (toPos (18,10)) res = IdeResultOk [ (Range (toPos (18, 10)) (toPos (18, 11)), "Maybe Int") + , (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -340,6 +359,7 @@ ghcmodSpec = arg = TP False uri (toPos (18,5)) res = IdeResultOk [ (Range (toPos (18, 5)) (toPos (18, 6)), "Int") + , (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -350,20 +370,8 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (15,5)) uri arg = TP False uri (toPos (15,5)) - res = IdeResultOk [] - -- TODO: the type is known, why not in the map? - -- [(Range (toPos (15, 1)) (toPos (14, 11)), "Maybe Int -> Maybe Int")] - testCommand testPlugins act "ghcmod" "type" arg res - - it "runs the type command, function parameter" $ withCurrentDirectory "./test/testdata" $ do - fp <- makeAbsolute "Types.hs" - let uri = filePathToUri fp - act = do - _ <- setTypecheckedModule uri - liftToGhc $ newTypeCmd (toPos (22,10)) uri - arg = TP False uri (toPos (22,10)) res = IdeResultOk - [ (Range (toPos (22, 10)) (toPos (22, 11)), "a -> a") + [ (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -376,6 +384,7 @@ ghcmodSpec = arg = TP False uri (toPos (22,10)) res = IdeResultOk [ (Range (toPos (22, 10)) (toPos (22, 11)), "a -> a") + , (Range (toPos (22, 1)) (toPos (22, 19)), "(a -> a) -> a -> a") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -388,6 +397,8 @@ ghcmodSpec = arg = TP False uri (toPos (25,26)) res = IdeResultOk [ (Range (toPos (25, 26)) (toPos (25, 27)), "(b -> c) -> (a -> b) -> a -> c") + , (Range (toPos (25, 20)) (toPos (25, 29)), "a -> c") + , (Range (toPos (25, 1)) (toPos (25, 34)), "(b -> c) -> (a -> b) -> a -> c") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -398,9 +409,10 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (25,20)) uri arg = TP False uri (toPos (25,20)) - res = IdeResultOk [] - -- TODO: do we want this? - --(Range (toPos (25, 20)) (toPos (25, 21)), "a -> c") + res = IdeResultOk + [ (Range (toPos (25, 20)) (toPos (25, 29)), "a -> c") + , (Range (toPos (25, 1)) (toPos (25, 34)), "(b -> c) -> (a -> b) -> a -> c") + ] testCommand testPlugins act "ghcmod" "type" arg res it "runs the type command, let binding, type of function" $ withCurrentDirectory "./test/testdata" $ do @@ -412,6 +424,7 @@ ghcmodSpec = arg = TP False uri (toPos (25,33)) res = IdeResultOk [ (Range (toPos (25, 33)) (toPos (25, 34)), "a -> c") + , (Range (toPos (25, 1)) (toPos (25, 34)), "(b -> c) -> (a -> b) -> a -> c") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -422,9 +435,9 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (25,5)) uri arg = TP False uri (toPos (25,5)) - res = IdeResultOk [] - -- TODO: the type is known, why not in the map? - -- (Range (toPos (25, 1)) (toPos (25, 9)), "(b -> c) -> (a -> b) -> a -> c") + res = IdeResultOk + [ (Range (toPos (25, 1)) (toPos (25, 34)), "(b -> c) -> (a -> b) -> a -> c") + ] testCommand testPlugins act "ghcmod" "type" arg res it "runs the type command, infix operator" $ withCurrentDirectory "./test/testdata" $ do @@ -436,6 +449,7 @@ ghcmodSpec = arg = TP False uri (toPos (28,25)) res = IdeResultOk [ (Range (toPos (28, 25)) (toPos (28, 28)), "(a -> b) -> IO a -> IO b") + , (Range (toPos (28, 1)) (toPos (28, 35)), "(a -> b) -> IO a -> IO b") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -463,6 +477,7 @@ ghcmodSpec = , (Range (toPos (33, 15)) (toPos (33, 19)), "Int -> Test -> ShowS") , (Range (toPos (33, 15)) (toPos (33, 19)), "Test -> String") , (Range (toPos (33, 15)) (toPos (33, 19)), "[Test] -> ShowS") + , (Range (toPos (33, 15)) (toPos (33, 19)), "Int -> Test -> ShowS") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -477,6 +492,7 @@ ghcmodSpec = [ (Range (toPos (33, 21)) (toPos (33, 23)), "(Test -> Test -> Bool) -> (Test -> Test -> Bool) -> Eq Test") , (Range (toPos (33, 21)) (toPos (33, 23)), "Test -> Test -> Bool") , (Range (toPos (33, 21)) (toPos (33, 23)), "Test -> Test -> Bool") + , (Range (toPos (33, 21)) (toPos (33, 23)), "Test -> Test -> Bool") ] testCommand testPlugins act "ghcmod" "type" arg res @@ -495,6 +511,7 @@ ghcmodSpec = let arg = TP False uri (toPos (5,9)) let res = IdeResultOk [(Range (toPos (5,9)) (toPos (5,10)), "Int") + , (Range (toPos (5,1)) (toPos (5,14)), "Int -> Int") ] testCommand testPlugins act "ghcmod" "type" arg res From 9507dc6f5988bfa1a716cf45fe9c39342ad83566 Mon Sep 17 00:00:00 2001 From: fendor Date: Sun, 28 Apr 2019 11:33:42 +0200 Subject: [PATCH 15/16] Add support for 8.2.1 - 8.4.4 for FunBind --- hie-plugin-api/Haskell/Ide/Engine/Compat.hs | 12 ++++++++++++ hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs | 5 ++--- 2 files changed, 14 insertions(+), 3 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Compat.hs b/hie-plugin-api/Haskell/Ide/Engine/Compat.hs index d13b4a541..72848ca86 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Compat.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Compat.hs @@ -7,6 +7,7 @@ import qualified GHC import qualified Type import qualified TcHsSyn import qualified TysWiredIn +import qualified Var #if MIN_VERSION_filepath(1,4,2) #else @@ -123,6 +124,17 @@ pattern HsMultiIfType t <- GHC.HsMultiIf t _ #endif +pattern FunBindType :: Type.Type -> GHC.HsBindLR GhcTc GhcTc +pattern FunBindType t <- +#if MIN_VERSION_ghc(8, 6, 0) + GHC.FunBind _ (GHC.L _ (Var.varType -> t)) _ _ _ +#elif MIN_VERSION_ghc(8, 4, 0) + GHC.FunBind (GHC.L _ (Var.varType -> t)) _ _ _ _ +#else + GHC.FunBind (GHC.L _ (Var.varType -> t)) _ _ _ _ +#endif + + #if MIN_VERSION_ghc(8, 6, 0) matchGroupType :: GHC.MatchGroupTc -> GHC.Type matchGroupType (GHC.MatchGroupTc args res) = Type.mkFunTys args res diff --git a/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs b/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs index b5d00d035..235a87f55 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs @@ -18,7 +18,6 @@ import qualified TcHsSyn import qualified CoreUtils import qualified Type import qualified Desugar -import qualified Var import Haskell.Ide.Engine.Compat import Haskell.Ide.Engine.ArtifactMap @@ -57,8 +56,8 @@ types hs_env = everythingInTypecheckedSourceM (ty `combineM` fun `combineM` funB funBind :: forall a . Data a => a -> IO TypeMap funBind term = case cast term of - (Just (GHC.L (GHC.RealSrcSpan spn) ((GHC.FunBind _ (GHC.L _ (idp :: GHC.IdP GhcTc)) _ _ _) :: GHC.HsBindLR GhcTc GhcTc))) -> - return (IM.singleton (rspToInt spn) (Var.varType idp)) + (Just (GHC.L (GHC.RealSrcSpan spn) (FunBindType t))) -> + return (IM.singleton (rspToInt spn) t) _ -> return IM.empty -- | Combine two queries into one using alternative combinator. From a5be92eeb7a0489ac7799aeb7a5573889677407a Mon Sep 17 00:00:00 2001 From: fendor Date: Sun, 28 Apr 2019 21:15:59 +0200 Subject: [PATCH 16/16] Add special case for ghc 8.2.2 --- test/unit/GhcModPluginSpec.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/test/unit/GhcModPluginSpec.hs b/test/unit/GhcModPluginSpec.hs index 3c40cc1ff..cca539ff3 100644 --- a/test/unit/GhcModPluginSpec.hs +++ b/test/unit/GhcModPluginSpec.hs @@ -478,6 +478,10 @@ ghcmodSpec = , (Range (toPos (33, 15)) (toPos (33, 19)), "Test -> String") , (Range (toPos (33, 15)) (toPos (33, 19)), "[Test] -> ShowS") , (Range (toPos (33, 15)) (toPos (33, 19)), "Int -> Test -> ShowS") +#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,4,0,0))) +#else + , (Range (toPos (33, 15)) (toPos (33, 19)), "[Test] -> ShowS") +#endif ] testCommand testPlugins act "ghcmod" "type" arg res @@ -493,6 +497,10 @@ ghcmodSpec = , (Range (toPos (33, 21)) (toPos (33, 23)), "Test -> Test -> Bool") , (Range (toPos (33, 21)) (toPos (33, 23)), "Test -> Test -> Bool") , (Range (toPos (33, 21)) (toPos (33, 23)), "Test -> Test -> Bool") +#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,4,0,0))) +#else + , (Range (toPos (33, 21)) (toPos (33, 23)), "Test -> Test -> Bool") +#endif ] testCommand testPlugins act "ghcmod" "type" arg res