1
1
module Wingman.Context where
2
2
3
- import Bag
4
- import Control.Arrow
5
- import Control.Monad.Reader
6
- import Development.IDE.GHC.Compat
7
- import OccName
8
- import TcRnTypes
9
- import Wingman.FeatureSet (FeatureSet )
10
- import Wingman.Types
11
-
12
-
13
- mkContext :: FeatureSet -> [(OccName , CType )] -> TcGblEnv -> Context
14
- mkContext features locals tcg = Context
3
+ import Bag
4
+ import Control.Arrow
5
+ import Control.Monad.Reader
6
+ import Data.Foldable.Extra (allM )
7
+ import Data.Maybe (fromMaybe , isJust )
8
+ import qualified Data.Set as S
9
+ import Development.IDE.GHC.Compat
10
+ import GhcPlugins (ExternalPackageState (eps_inst_env ), piResultTys )
11
+ import InstEnv (lookupInstEnv , InstEnvs (.. ), is_dfun )
12
+ import OccName
13
+ import TcRnTypes
14
+ import TcType (tcSplitTyConApp , tcSplitPhiTy )
15
+ import TysPrim (alphaTys )
16
+ import Wingman.FeatureSet (FeatureSet )
17
+ import Wingman.Judgements.Theta
18
+ import Wingman.Types
19
+
20
+
21
+ mkContext
22
+ :: FeatureSet
23
+ -> [(OccName , CType )]
24
+ -> TcGblEnv
25
+ -> ExternalPackageState
26
+ -> KnownThings
27
+ -> [Evidence ]
28
+ -> Context
29
+ mkContext features locals tcg eps kt ev = Context
15
30
{ ctxDefiningFuncs = locals
16
31
, ctxModuleFuncs = fmap splitId
17
32
. (getFunBindId =<< )
18
33
. fmap unLoc
19
34
. bagToList
20
35
$ tcg_binds tcg
21
36
, ctxFeatureSet = features
37
+ , ctxInstEnvs =
38
+ InstEnvs
39
+ (eps_inst_env eps)
40
+ (tcg_inst_env tcg)
41
+ (tcVisibleOrphanMods tcg)
42
+ , ctxKnownThings = kt
43
+ , ctxTheta = evidenceToThetaType ev
22
44
}
23
45
24
46
@@ -37,3 +59,55 @@ getFunBindId _ = []
37
59
getCurrentDefinitions :: MonadReader Context m => m [(OccName , CType )]
38
60
getCurrentDefinitions = asks ctxDefiningFuncs
39
61
62
+
63
+ ------------------------------------------------------------------------------
64
+ -- | Extract something from 'KnownThings'.
65
+ getKnownThing :: MonadReader Context m => (KnownThings -> a ) -> m a
66
+ getKnownThing f = asks $ f . ctxKnownThings
67
+
68
+
69
+ ------------------------------------------------------------------------------
70
+ -- | Like 'getInstance', but uses a class from the 'KnownThings'.
71
+ getKnownInstance :: MonadReader Context m => (KnownThings -> Class ) -> [Type ] -> m (Maybe (Class , PredType ))
72
+ getKnownInstance f tys = do
73
+ cls <- getKnownThing f
74
+ getInstance cls tys
75
+
76
+
77
+ ------------------------------------------------------------------------------
78
+ -- | Determine if there is an instance that exists for the given 'Class' at the
79
+ -- specified types. Deeply checks contexts to ensure the instance is actually
80
+ -- real.
81
+ --
82
+ -- If so, this returns a 'PredType' that corresponds to the type of the
83
+ -- dictionary.
84
+ getInstance :: MonadReader Context m => Class -> [Type ] -> m (Maybe (Class , PredType ))
85
+ getInstance cls tys = do
86
+ env <- asks ctxInstEnvs
87
+ let (mres, _, _) = lookupInstEnv False env cls tys
88
+ case mres of
89
+ ((inst, mapps) : _) -> do
90
+ -- Get the instantiated type of the dictionary
91
+ let df = piResultTys (idType $ is_dfun inst) $ zipWith fromMaybe alphaTys mapps
92
+ -- pull off its resulting arguments
93
+ let (theta, df') = tcSplitPhiTy df
94
+ allM hasClassInstance theta >>= \ case
95
+ True -> pure $ Just (cls, df')
96
+ False -> pure Nothing
97
+ _ -> pure Nothing
98
+
99
+
100
+ ------------------------------------------------------------------------------
101
+ -- | Like 'getInstance', but only returns whether or not it succeeded. Can fail
102
+ -- fast, and uses a cached Theta from the context.
103
+ hasClassInstance :: MonadReader Context m => PredType -> m Bool
104
+ hasClassInstance predty = do
105
+ theta <- asks ctxTheta
106
+ case S. member (CType predty) theta of
107
+ True -> pure True
108
+ False -> do
109
+ let (con, apps) = tcSplitTyConApp predty
110
+ case tyConClass_maybe con of
111
+ Nothing -> pure False
112
+ Just cls -> fmap isJust $ getInstance cls apps
113
+
0 commit comments