This repository was archived by the owner on Oct 7, 2020. It is now read-only.
-
Notifications
You must be signed in to change notification settings - Fork 206
Typemap reimplementation #1186
Merged
Merged
Typemap reimplementation #1186
Changes from all commits
Commits
Show all changes
16 commits
Select commit
Hold shift + click to select a range
fb3eb46
Change TypeMap implementation
fendor ea5f819
Replace GHC.Name with GHC.Id in genTypeMap
fendor 11bbe7f
Add comment
fendor 1805ebb
Remove unused function and add comment
fendor aaa6968
Add Pattern Synonyms for GHC 8.6.4
fendor 823d35e
Add support for GHC 8.4.4 and GHC 8.2.2
fendor 6a7a5b1
Fix GhcModPluginSpec tests
fendor a81a265
Add more tests for type information
fendor 49822a0
Add more tests for the type map impl
fendor 6b655ee
Update documentation of getType
fendor 8abb57c
Actually pattern match on the results of tyOpt
fendor 81c866e
Adapt tests and add tests for deriving clause
fendor aec6709
Reformat tests
fendor 91dd4c7
Add type information for fun pat
fendor 9507dc6
Add support for 8.2.1 - 8.4.4 for FunBind
fendor a5be92e
Add special case for ghc 8.2.2
fendor File filter
Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
There are no files selected for viewing
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -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<https://gitlab.haskell.org/ghc/ghc/blob/1f5cc9dc8aeeafa439d6d12c3c4565ada524b926/compiler/hieFile/HieAst.hs> | ||
| -- Slightly adapted to work for the supported GHC versions 8.2.1 - 8.6.4 | ||
| -- | ||
| -- See #16233<https://gitlab.haskell.org/ghc/ghc/issues/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 | ||
fendor marked this conversation as resolved.
Show resolved
Hide resolved
|
||
| 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 | ||
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -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) |
Oops, something went wrong.
Add this suggestion to a batch that can be applied as a single commit.
This suggestion is invalid because no changes were made to the code.
Suggestions cannot be applied while the pull request is closed.
Suggestions cannot be applied while viewing a subset of changes.
Only one suggestion per line can be applied in a batch.
Add this suggestion to a batch that can be applied as a single commit.
Applying suggestions on deleted lines is not supported.
You must change the existing code in this line in order to create a valid suggestion.
Outdated suggestions cannot be applied.
This suggestion has been applied or marked resolved.
Suggestions cannot be applied from pending reviews.
Suggestions cannot be applied on multi-line comments.
Suggestions cannot be applied while the pull request is queued to merge.
Suggestion cannot be applied right now. Please check back later.
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
Can just have the
elseclause here I think.There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
Yeah, I wanted to ask that anyway, do we prefer easy to read, e.g. always three clauses although they often completely overlap, or conciseness when it comes to CPP?
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
I prefer not having the duplication and just having two clauses when possible.