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 )
20 import Util ( assertPanic )
25 %************************************************************************
29 %************************************************************************
32 type TemplateTyVar = GenTyVar Bool
33 type TemplateType = GenType Bool
34 -- The Bool is True for template type variables;
35 -- that is, ones that can be bound
39 | SpecEnv [([TemplateType], value)]
41 specEnvValues :: SpecEnv value -> [value]
42 specEnvValues EmptySE = []
43 specEnvValues (SpecEnv alist) = map snd alist
45 specEnvToList :: SpecEnv value -> [([TemplateTyVar], [TemplateType], value)]
46 specEnvToList EmptySE = []
47 specEnvToList (SpecEnv alist)
50 do_item (tys, val) = (tyvars, tys, val)
52 tyvars = filter tyVarFlexi (tyVarSetToList (tyVarsOfTypes tys))
55 In some SpecEnvs overlap is prohibited; that is, no pair of templates unify.
57 In others, overlap is permitted, but only in such a way that one can make
58 a unique choice when looking up. That is, overlap is only permitted if
59 one template matches the other, or vice versa. So this is ok:
67 If overlap is permitted, the list is kept most specific first, so that
68 the first lookup is the right choice.
71 For now we just use association lists.
74 emptySpecEnv :: SpecEnv a
75 emptySpecEnv = EmptySE
77 isEmptySpecEnv EmptySE = True
78 isEmptySpecEnv _ = False
81 @lookupSpecEnv@ looks up in a @SpecEnv@, using a one-way match. Since the env is kept
82 ordered, the first match must be the only one.
83 The thing we are looking up can have an
84 arbitrary "flexi" part.
87 lookupSpecEnv :: SpecEnv value -- The envt
88 -> [GenType flexi] -- Key
89 -> Maybe (TyVarEnv (GenType flexi), value)
91 lookupSpecEnv EmptySE key = Nothing
92 lookupSpecEnv (SpecEnv alist) key
96 find ((tpl, val) : rest)
97 = case matchTys tpl key of
99 Just (subst, leftovers) -> ASSERT( null leftovers )
103 @addToSpecEnv@ extends a @SpecEnv@, checking for overlaps.
105 A boolean flag controls overlap reporting.
107 True => overlap is permitted, but only if one template matches the other;
108 not if they unify but neither is
111 addToSpecEnv :: Bool -- True <=> overlap permitted
112 -> SpecEnv value -- Envt
113 -> [TyVar] -> [Type] -> value -- New item
114 -> MaybeErr (SpecEnv value) -- Success...
115 ([TemplateType], value) -- Failure: Offending overlap
117 addToSpecEnv overlap_ok spec_env tvs tys value
119 EmptySE -> returnMaB (SpecEnv [ins_item])
120 SpecEnv alist -> insert alist `thenMaB` \ alist' ->
121 returnMaB (SpecEnv alist')
123 ins_item = (ins_tys, value)
124 ins_tys = map (applyToTyVars mk_tv) tys
126 mk_tv tv = mkTyVarTy (setTyVarFlexi tv (tv `elem` tvs))
127 -- tvs identifies the template variables
129 insert [] = returnMaB [ins_item]
130 insert alist@(cur_item@(cur_tys, _) : rest)
131 | unifiable && not overlap_ok = failMaB cur_item
132 | unifiable && ins_item_more_specific = returnMaB (ins_item : alist)
133 | unifiable && not cur_item_more_specific = failMaB cur_item
134 | otherwise = -- Less specific, or not unifiable... carry on
135 insert rest `thenMaB` \ rest' ->
136 returnMaB (cur_item : rest')
138 unifiable = maybeToBool (unifyTyListsX cur_tys ins_tys)
139 ins_item_more_specific = maybeToBool (matchTys cur_tys ins_tys)
140 cur_item_more_specific = maybeToBool (matchTys ins_tys cur_tys)
143 Finally, during simplification we must apply the current substitution to
147 substSpecEnv :: TyVarEnv Type -> (val -> val) -> SpecEnv val -> SpecEnv val
148 substSpecEnv ty_env val_fn EmptySE = EmptySE
149 substSpecEnv ty_env val_fn (SpecEnv alist)
150 = SpecEnv [(map ty_fn tys, val_fn val) | (tys, val) <- alist]
152 ty_fn = applyToTyVars tyvar_fn
154 -- Apply the substitution; but if we ever substitute
155 -- we need to convert a Type to a TemplateType
156 tyvar_fn tv | tyVarFlexi tv = mkTyVarTy tv
157 | otherwise = case lookupTyVarEnv ty_env tv of
158 Nothing -> mkTyVarTy tv
159 Just ty -> applyToTyVars set_non_tpl ty
161 set_non_tpl tv = mkTyVarTy (setTyVarFlexi tv False)