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/Compat.hs b/hie-plugin-api/Haskell/Ide/Engine/Compat.hs index 756dab9bd..72848ca86 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 +import qualified Var + #if MIN_VERSION_filepath(1,4,2) #else import Data.List @@ -27,3 +35,108 @@ isExtensionOf :: String -> FilePath -> Bool isExtensionOf ext@('.':_) = isSuffixOf ext . takeExtensions 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 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 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 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 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 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 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 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 + +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 +#endif + 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..235a87f55 --- /dev/null +++ b/hie-plugin-api/Haskell/Ide/Engine/TypeMap.hs @@ -0,0 +1,152 @@ +{-# 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 Data.Data as Data +import Control.Monad.IO.Class +import Data.Maybe +import qualified TcHsSyn +import qualified CoreUtils +import qualified Type +import qualified Desugar +import Haskell.Ide.Engine.Compat + +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 + liftIO $ types hs_env typecheckedSource + + +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 +types hs_env = everythingInTypecheckedSourceM (ty `combineM` fun `combineM` funBind) + 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 + + funBind :: forall a . Data a => a -> IO TypeMap + funBind term = case cast term of + (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. +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 + +-- | 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. +-- +-- Implementation is taken from: HieAst.hs +-- Slightly adapted to work for the supported GHC versions 8.2.1 - 8.6.4 +-- +-- See #16233 +getType + :: 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 + tyOpt = case e' of + 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 + Just t -> return $ Just (spn ,t) + Nothing + | skipDesugaring e' -> pure Nothing + | otherwise -> do + (_, mbe) <- Desugar.deSugarExpr hs_env e + let res = (spn, ) . CoreUtils.exprType <$> mbe + pure res + where + -- | 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 diff --git a/test/testdata/Types.hs b/test/testdata/Types.hs new file mode 100644 index 000000000..8d6b4338b --- /dev/null +++ b/test/testdata/Types.hs @@ -0,0 +1,33 @@ +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 + +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 699e4efb8..cca539ff3 100644 --- a/test/unit/GhcModPluginSpec.hs +++ b/test/unit/GhcModPluginSpec.hs @@ -80,9 +80,9 @@ 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" $ 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 @@ -90,12 +90,421 @@ 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,14)), "Int") - ,(Range (toPos (5,1)) (toPos (5,14)), "Int -> 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" + 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 ()") + , (Range (toPos (2, 1)) (toPos (2,24)), "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, 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") + , (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> 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") + , (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> Int") + ] + 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") + , (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> Int") ] 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") + , (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> 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 + [ (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 + + 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") + , (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> 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") + , (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 + + 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") + , (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 + + 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") + , (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 + + 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") + , (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 + + 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") + , (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 + + 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") + , (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe 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") + , (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> 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") + , (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, 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") + , (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, 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 + [ (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 + 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") + , (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> 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") + , (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe 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 + [ (Range (toPos (15, 1)) (toPos (19, 19)), "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 (22, 1)) (toPos (22, 19)), "(a -> a) -> 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") + , (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, 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 + [ (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 + 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") + , (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, 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 + [ (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 + 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") + , (Range (toPos (28, 1)) (toPos (28, 35)), "(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") + , (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 + + 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") + , (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 + +-- ---------------------------------------------------------------------------- it "runs the type command with an absolute path from another folder, correct params" $ do fp <- makeAbsolute "./test/testdata/HaReRename.hs" cd <- getCurrentDirectory @@ -110,8 +519,7 @@ 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") + , (Range (toPos (5,1)) (toPos (5,14)), "Int -> Int") ] testCommand testPlugins act "ghcmod" "type" arg res