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)
99 = case matchTys tpl key of
101 Just (subst, leftovers) -> ASSERT( null leftovers )
105 @addToSpecEnv@ extends a @SpecEnv@, checking for overlaps.
107 A boolean flag controls overlap reporting.
109 True => overlap is permitted, but only if one template matches the other;
110 not if they unify but neither is
113 addToSpecEnv :: Bool -- True <=> overlap permitted
114 -> SpecEnv value -- Envt
115 -> [TyVar] -> [Type] -> value -- New item
116 -> MaybeErr (SpecEnv value) -- Success...
117 ([TemplateType], value) -- Failure: Offending overlap
119 addToSpecEnv overlap_ok spec_env tvs tys value
121 EmptySE -> returnMaB (SpecEnv [ins_item])
122 SpecEnv alist -> insert alist `thenMaB` \ alist' ->
123 returnMaB (SpecEnv alist')
125 ins_item = (ins_tys, value)
126 ins_tys = map (applyToTyVars mk_tv) tys
128 mk_tv tv = mkTyVarTy (setTyVarFlexi tv (tv `elem` tvs))
129 -- tvs identifies the template variables
131 insert [] = returnMaB [ins_item]
132 insert alist@(cur_item@(cur_tys, _) : rest)
133 | unifiable && not overlap_ok = failMaB cur_item
134 | unifiable && ins_item_more_specific = returnMaB (ins_item : alist)
135 | unifiable && not cur_item_more_specific = failMaB cur_item
136 | otherwise = -- Less specific, or not unifiable... carry on
137 insert rest `thenMaB` \ rest' ->
138 returnMaB (cur_item : rest')
140 unifiable = maybeToBool (unifyTyListsX cur_tys ins_tys)
141 ins_item_more_specific = maybeToBool (matchTys cur_tys ins_tys)
142 cur_item_more_specific = maybeToBool (matchTys ins_tys cur_tys)
145 Finally, during simplification we must apply the current substitution to
149 substSpecEnv :: TyVarEnv Type -> (val -> val) -> SpecEnv val -> SpecEnv val
150 substSpecEnv ty_env val_fn EmptySE = EmptySE
151 substSpecEnv ty_env val_fn (SpecEnv alist)
152 = SpecEnv [(map ty_fn tys, val_fn val) | (tys, val) <- alist]
154 ty_fn = applyToTyVars tyvar_fn
156 -- Apply the substitution; but if we ever substitute
157 -- we need to convert a Type to a TemplateType
158 tyvar_fn tv | tyVarFlexi tv = mkTyVarTy tv
159 | otherwise = case lookupTyVarEnv ty_env tv of
160 Nothing -> mkTyVarTy tv
161 Just ty -> applyToTyVars set_non_tpl ty
163 set_non_tpl tv = mkTyVarTy (setTyVarFlexi tv False)