2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[SpecEnv]{Specialisation info about an @Id@}
9 emptySpecEnv, isEmptySpecEnv,
10 specEnvValues, specEnvToList,
11 addToSpecEnv, lookupSpecEnv, substSpecEnv
14 #include "HsVersions.h"
16 import Type ( Type, GenType, mkTyVarTy, matchTys, tyVarsOfTypes, applyToTyVars )
17 import TyVar ( TyVar, GenTyVar, TyVarEnv, tyVarFlexi, setTyVarFlexi, lookupTyVarEnv, tyVarSetToList )
18 import Unify ( Subst, unifyTyListsX )
21 import Util ( assertPanic )
26 %************************************************************************
30 %************************************************************************
33 type TemplateTyVar = GenTyVar Bool
34 type TemplateType = GenType Bool
35 -- The Bool is True for template type variables;
36 -- that is, ones that can be bound
40 | SpecEnv [([TemplateType], value)]
42 specEnvValues :: SpecEnv value -> [value]
43 specEnvValues EmptySE = []
44 specEnvValues (SpecEnv alist) = map snd alist
46 specEnvToList :: SpecEnv value -> [([TemplateTyVar], [TemplateType], value)]
47 specEnvToList EmptySE = []
48 specEnvToList (SpecEnv alist)
51 do_item (tys, val) = (tyvars, tys, val)
53 tyvars = filter tyVarFlexi (tyVarSetToList (tyVarsOfTypes tys))
56 In some SpecEnvs overlap is prohibited; that is, no pair of templates unify.
58 In others, overlap is permitted, but only in such a way that one can make
59 a unique choice when looking up. That is, overlap is only permitted if
60 one template matches the other, or vice versa. So this is ok:
68 If overlap is permitted, the list is kept most specific first, so that
69 the first lookup is the right choice.
72 For now we just use association lists.
75 emptySpecEnv :: SpecEnv a
76 emptySpecEnv = EmptySE
78 isEmptySpecEnv EmptySE = True
79 isEmptySpecEnv _ = False
82 @lookupSpecEnv@ looks up in a @SpecEnv@, using a one-way match. Since the env is kept
83 ordered, the first match must be the only one.
84 The thing we are looking up can have an
85 arbitrary "flexi" part.
88 lookupSpecEnv :: SDoc -- For error report
89 -> SpecEnv value -- The envt
90 -> [GenType flexi] -- Key
91 -> Maybe (TyVarEnv (GenType flexi), value)
93 lookupSpecEnv doc EmptySE key = Nothing
94 lookupSpecEnv doc (SpecEnv alist) key
98 find ((tpl, val) : rest)
101 if length tpl > length key then
102 pprTrace "lookupSpecEnv" (doc <+> ppr tpl <+> ppr key) $
106 case matchTys tpl key of
108 Just (subst, leftovers) -> ASSERT( null leftovers )
112 @addToSpecEnv@ extends a @SpecEnv@, checking for overlaps.
114 A boolean flag controls overlap reporting.
116 True => overlap is permitted, but only if one template matches the other;
117 not if they unify but neither is
120 addToSpecEnv :: Bool -- True <=> overlap permitted
121 -> SpecEnv value -- Envt
122 -> [TyVar] -> [Type] -> value -- New item
123 -> MaybeErr (SpecEnv value) -- Success...
124 ([TemplateType], value) -- Failure: Offending overlap
126 addToSpecEnv overlap_ok spec_env tvs tys value
128 EmptySE -> returnMaB (SpecEnv [ins_item])
129 SpecEnv alist -> insert alist `thenMaB` \ alist' ->
130 returnMaB (SpecEnv alist')
132 ins_item = (ins_tys, value)
133 ins_tys = map (applyToTyVars mk_tv) tys
135 mk_tv tv = mkTyVarTy (setTyVarFlexi tv (tv `elem` tvs))
136 -- tvs identifies the template variables
138 insert [] = returnMaB [ins_item]
139 insert alist@(cur_item@(cur_tys, _) : rest)
140 | unifiable && not overlap_ok = failMaB cur_item
141 | unifiable && ins_item_more_specific = returnMaB (ins_item : alist)
142 | unifiable && not cur_item_more_specific = failMaB cur_item
143 | otherwise = -- Less specific, or not unifiable... carry on
144 insert rest `thenMaB` \ rest' ->
145 returnMaB (cur_item : rest')
147 unifiable = maybeToBool (unifyTyListsX cur_tys ins_tys)
148 ins_item_more_specific = maybeToBool (matchTys cur_tys ins_tys)
149 cur_item_more_specific = maybeToBool (matchTys ins_tys cur_tys)
152 Finally, during simplification we must apply the current substitution to
156 substSpecEnv :: TyVarEnv Type -> (val -> val) -> SpecEnv val -> SpecEnv val
157 substSpecEnv ty_env val_fn EmptySE = EmptySE
158 substSpecEnv ty_env val_fn (SpecEnv alist)
159 = SpecEnv [(map ty_fn tys, val_fn val) | (tys, val) <- alist]
161 ty_fn = applyToTyVars tyvar_fn
163 -- Apply the substitution; but if we ever substitute
164 -- we need to convert a Type to a TemplateType
165 tyvar_fn tv | tyVarFlexi tv = mkTyVarTy tv
166 | otherwise = case lookupTyVarEnv ty_env tv of
167 Nothing -> mkTyVarTy tv
168 Just ty -> applyToTyVars set_non_tpl ty
170 set_non_tpl tv = mkTyVarTy (setTyVarFlexi tv False)