|
| 1 | +{-# LANGUAGE TupleSections #-} |
| 2 | +{-# LANGUAGE AllowAmbiguousTypes #-} |
| 3 | +{-# LANGUAGE RankNTypes #-} |
| 4 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 5 | +{-# LANGUAGE TypeApplications #-} |
| 6 | +{-# LANGUAGE LambdaCase #-} |
| 7 | +module Haskell.Ide.Engine.TypeMap where |
| 8 | + |
| 9 | +import qualified Data.IntervalMap.FingerTree as IM |
| 10 | + |
| 11 | +import qualified GHC |
| 12 | +import GHC ( TypecheckedModule ) |
| 13 | + |
| 14 | +import Data.Data as Data |
| 15 | +import Control.Monad.IO.Class |
| 16 | +import Data.Maybe |
| 17 | +import qualified TcHsSyn |
| 18 | +import qualified CoreUtils |
| 19 | +import qualified Type |
| 20 | +import qualified Desugar |
| 21 | +import Haskell.Ide.Engine.Compat |
| 22 | + |
| 23 | +import Haskell.Ide.Engine.ArtifactMap |
| 24 | + |
| 25 | +-- | Generate a mapping from an Interval to types. |
| 26 | +-- Intervals may overlap and return more specific results. |
| 27 | +genTypeMap :: GHC.GhcMonad m => TypecheckedModule -> m TypeMap |
| 28 | +genTypeMap tm = do |
| 29 | + let typecheckedSource = GHC.tm_typechecked_source tm |
| 30 | + hs_env <- GHC.getSession |
| 31 | + liftIO $ types hs_env typecheckedSource |
| 32 | + |
| 33 | + |
| 34 | +everythingInTypecheckedSourceM |
| 35 | + :: Data x => (forall a . Data a => a -> IO TypeMap) -> x -> IO TypeMap |
| 36 | +everythingInTypecheckedSourceM = everythingButTypeM @GHC.Id |
| 37 | + |
| 38 | + |
| 39 | +-- | Obtain details map for types. |
| 40 | +types :: GHC.HscEnv -> GHC.TypecheckedSource -> IO TypeMap |
| 41 | +types hs_env = everythingInTypecheckedSourceM (ty `combineM` fun `combineM` funBind) |
| 42 | + where |
| 43 | + ty :: forall a . Data a => a -> IO TypeMap |
| 44 | + ty term = case cast term of |
| 45 | + (Just lhsExprGhc@(GHC.L (GHC.RealSrcSpan spn) _)) -> |
| 46 | + getType hs_env lhsExprGhc >>= \case |
| 47 | + Nothing -> return IM.empty |
| 48 | + Just (_, typ) -> return (IM.singleton (rspToInt spn) typ) |
| 49 | + _ -> return IM.empty |
| 50 | + |
| 51 | + fun :: forall a . Data a => a -> IO TypeMap |
| 52 | + fun term = case cast term of |
| 53 | + (Just (GHC.L (GHC.RealSrcSpan spn) hsPatType)) -> |
| 54 | + return (IM.singleton (rspToInt spn) (TcHsSyn.hsPatType hsPatType)) |
| 55 | + _ -> return IM.empty |
| 56 | + |
| 57 | + funBind :: forall a . Data a => a -> IO TypeMap |
| 58 | + funBind term = case cast term of |
| 59 | + (Just (GHC.L (GHC.RealSrcSpan spn) (FunBindType t))) -> |
| 60 | + return (IM.singleton (rspToInt spn) t) |
| 61 | + _ -> return IM.empty |
| 62 | + |
| 63 | +-- | Combine two queries into one using alternative combinator. |
| 64 | +combineM |
| 65 | + :: (forall a . Data a => a -> IO TypeMap) |
| 66 | + -> (forall a . Data a => a -> IO TypeMap) |
| 67 | + -> (forall a . Data a => a -> IO TypeMap) |
| 68 | +combineM f g x = do |
| 69 | + a <- f x |
| 70 | + b <- g x |
| 71 | + return (a `IM.union` b) |
| 72 | + |
| 73 | +-- | Variation of "everything" that does not recurse into children of type t |
| 74 | +-- requires AllowAmbiguousTypes |
| 75 | +everythingButTypeM |
| 76 | + :: forall t |
| 77 | + . (Typeable t) |
| 78 | + => (forall a . Data a => a -> IO TypeMap) |
| 79 | + -> (forall a . Data a => a -> IO TypeMap) |
| 80 | +everythingButTypeM f = everythingButM $ (,) <$> f <*> isType @t |
| 81 | + |
| 82 | +-- | Returns true if a == t. |
| 83 | +-- requires AllowAmbiguousTypes |
| 84 | +isType :: forall a b . (Typeable a, Typeable b) => b -> Bool |
| 85 | +isType _ = isJust $ eqT @a @b |
| 86 | + |
| 87 | +-- | Variation of "everything" with an added stop condition |
| 88 | +-- Just like 'everything', this is stolen from SYB package. |
| 89 | +everythingButM |
| 90 | + :: (forall a . Data a => a -> (IO TypeMap, Bool)) |
| 91 | + -> (forall a . Data a => a -> IO TypeMap) |
| 92 | +everythingButM f x = do |
| 93 | + let (v, stop) = f x |
| 94 | + if stop |
| 95 | + then v |
| 96 | + else Data.gmapQr |
| 97 | + (\e acc -> do |
| 98 | + e' <- e |
| 99 | + a <- acc |
| 100 | + return (e' `IM.union` a) |
| 101 | + ) |
| 102 | + v |
| 103 | + (everythingButM f) |
| 104 | + x |
| 105 | + |
| 106 | +-- | Attempts to get the type for expressions in a lazy and cost saving way. |
| 107 | +-- Avoids costly desugaring of Expressions and only obtains the type at the leaf of an expression. |
| 108 | +-- |
| 109 | +-- Implementation is taken from: HieAst.hs<https://gitlab.haskell.org/ghc/ghc/blob/1f5cc9dc8aeeafa439d6d12c3c4565ada524b926/compiler/hieFile/HieAst.hs> |
| 110 | +-- Slightly adapted to work for the supported GHC versions 8.2.1 - 8.6.4 |
| 111 | +-- |
| 112 | +-- See #16233<https://gitlab.haskell.org/ghc/ghc/issues/16233> |
| 113 | +getType |
| 114 | + :: GHC.HscEnv -> GHC.LHsExpr GhcTc -> IO (Maybe (GHC.SrcSpan, Type.Type)) |
| 115 | +getType hs_env e@(GHC.L spn e') = |
| 116 | + -- Some expression forms have their type immediately available |
| 117 | + let |
| 118 | + tyOpt = case e' of |
| 119 | + HsOverLitType t -> Just t |
| 120 | + HsLitType t -> Just t |
| 121 | + HsLamType t -> Just t |
| 122 | + HsLamCaseType t -> Just t |
| 123 | + HsCaseType t -> Just t |
| 124 | + ExplicitListType t -> Just t |
| 125 | + ExplicitSumType t -> Just t |
| 126 | + HsMultiIfType t -> Just t |
| 127 | + |
| 128 | + _ -> Nothing |
| 129 | + in case tyOpt of |
| 130 | + Just t -> return $ Just (spn ,t) |
| 131 | + Nothing |
| 132 | + | skipDesugaring e' -> pure Nothing |
| 133 | + | otherwise -> do |
| 134 | + (_, mbe) <- Desugar.deSugarExpr hs_env e |
| 135 | + let res = (spn, ) . CoreUtils.exprType <$> mbe |
| 136 | + pure res |
| 137 | + where |
| 138 | + -- | Skip desugaring of these expressions for performance reasons. |
| 139 | + -- |
| 140 | + -- See impact on Haddock output (esp. missing type annotations or links) |
| 141 | + -- before marking more things here as 'False'. See impact on Haddock |
| 142 | + -- performance before marking more things as 'True'. |
| 143 | + skipDesugaring :: GHC.HsExpr a -> Bool |
| 144 | + skipDesugaring expression = case expression of |
| 145 | + GHC.HsVar{} -> False |
| 146 | + GHC.HsUnboundVar{} -> False |
| 147 | + GHC.HsConLikeOut{} -> False |
| 148 | + GHC.HsRecFld{} -> False |
| 149 | + GHC.HsOverLabel{} -> False |
| 150 | + GHC.HsIPVar{} -> False |
| 151 | + GHC.HsWrap{} -> False |
| 152 | + _ -> True |
0 commit comments