2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[TcMonadFns]{Auxilliary functions for typechecker monad}
7 #include "HsVersions.h"
10 newDict, newDicts, newMethod, newOverloadedLit,
13 newOpenTyVarTy, newPolyTyVarTy,
16 --UNUSED: newLocalWithOpenTyVarTy, newLocalWithPolyTyVarTy,
18 newSpecPragmaId, newSpecId,
20 newLocalsWithOpenTyVarTys, newLocalsWithPolyTyVarTys,
22 mkIdsWithOpenTyVarTys, mkIdsWithPolyTyVarTys,
25 applyTcSubstAndCollectTyVars,
26 applyTcSubstAndExpectTyVars,
28 -- and to make the interface self-sufficient...
29 Bag, Class, Binds, MonoBinds, TypecheckedPat, Id, Inst, SpecInfo,
30 OverloadedLit, InstOrigin, TcResult, Name, SrcLoc, Subst, Maybe,
31 Error(..), TyVar, UniType, UnifyErrContext, UniqueSupply,
32 PprStyle, Pretty(..), PrettyRep
35 import TcMonad -- the underlying monadery
39 import Id ( mkId, mkUserLocal, mkSpecPragmaId, mkSpecId,
40 selectIdInfoForSpecId, Id, DictVar(..) )
42 import Inst ( mkDict, mkMethod, mkLitInst,
43 Inst(..), -- .. for pragmas
44 OverloadedLit, InstOrigin
46 import Maybes ( Maybe(..) )
48 import Errors ( Error(..), UnifyErrInfo )
49 import Unique ( Unique, UniqueSupply )
53 %************************************************************************
55 \subsection[TcMonadFns-newNameThings]{Making new things from the name supply}
57 %************************************************************************
59 @newPolyTyVars@ takes list of ``old'' template type vars, and manufactures
60 a list of freshly-uniqued type vars.
63 copyTyVars :: [TyVarTemplate] -- Old type vars
65 ([(TyVarTemplate,TauType)],--Old-to-new assoc list
66 [TyVar], -- New type vars
67 [TauType]) -- New type vars wrapped in a UniTyVar
70 = getTyVarUniquesTc (length old_tyvars) `thenNF_Tc` \ new_uniqs ->
71 returnNF_Tc (instantiateTyVarTemplates old_tyvars new_uniqs)
73 newOpenTyVarTys :: Int -> NF_TcM [UniType]
75 = getTyVarUniquesTc n `thenLazilyNF_Tc` \ new_uniqs ->
76 returnNF_Tc [mkTyVarTy (mkOpenSysTyVar u) | u <- new_uniqs]
78 newPolyTyVarTys :: Int -> NF_TcM [UniType]
80 = getTyVarUniquesTc n `thenLazilyNF_Tc` \ new_uniqs ->
81 returnNF_Tc [mkTyVarTy (mkPolySysTyVar u) | u <- new_uniqs]
83 newOpenTyVarTy, newPolyTyVarTy :: NF_TcM UniType
85 = getTyVarUniqueTc `thenLazilyNF_Tc` \ new_uniq ->
86 returnNF_Tc (mkTyVarTy (mkOpenSysTyVar new_uniq))
89 = getTyVarUniqueTc `thenLazilyNF_Tc` \ new_uniq ->
90 returnNF_Tc (mkTyVarTy (mkPolySysTyVar new_uniq))
93 The functions @newDicts@, @newMethod@, and @newOverloadedLit@ build
97 newDicts :: InstOrigin -> ThetaType -> NF_TcM [Inst]
99 = getUniquesTc (length theta) `thenNF_Tc` \ new_uniqs ->
100 returnNF_Tc (zipWith mk_dict_var new_uniqs theta)
102 mk_dict_var u (clas, ty) = mkDict u clas ty orig
104 newDict :: InstOrigin -> Class -> UniType -> NF_TcM Inst
106 = getUniqueTc `thenNF_Tc` \ new_uniq ->
107 returnNF_Tc (mkDict new_uniq clas ty orig)
109 newMethod :: InstOrigin -> Id -> [UniType] -> NF_TcM Inst
110 newMethod orig id tys
111 = getUniqueTc `thenNF_Tc` \ new_uniq ->
112 returnNF_Tc (mkMethod new_uniq id tys orig)
114 newOverloadedLit :: InstOrigin -> OverloadedLit -> UniType -> NF_TcM Inst
115 newOverloadedLit orig lit ty
116 = getUniqueTc `thenNF_Tc` \ new_uniq ->
117 returnNF_Tc (mkLitInst new_uniq lit ty orig)
120 Make a fresh batch of locals, derived from name, each typed with a fresh
121 type variable, and return an LVE of them.
124 \item @mkIdsWithTyVarTys@ uses the supplied names directly (including their
125 uniques), and generates a @TopId@ or @Local@ depending on whether
126 the name is a @FullName@ or not.
128 \item @mkIdsWithGivenTys@ does as above, but the types are supplied.
132 mkIdsWithPolyTyVarTys, mkIdsWithOpenTyVarTys :: [Name] -> NF_TcM LVE
133 mkIdsWithPolyTyVarTys names
135 no_of_names = length names
137 newPolyTyVarTys no_of_names `thenNF_Tc` \ tys ->
138 returnNF_Tc (mkIdsWithGivenTys names tys (nOfThem no_of_names noIdInfo))
140 mkIdsWithOpenTyVarTys names
142 no_of_names = length names
144 newOpenTyVarTys no_of_names `thenNF_Tc` \ tys ->
145 returnNF_Tc (mkIdsWithGivenTys names tys (nOfThem no_of_names noIdInfo))
147 mkIdsWithGivenTys :: [Name] -> [UniType] -> [IdInfo] -> LVE
148 -- not monadic any more (WDP 94/05)
149 -- Not done w/ zips/etc for "efficiency" (?)
150 mkIdsWithGivenTys [] [] _ = []
151 mkIdsWithGivenTys (name:names) (ty:tys) (id_info:id_infos)
152 = (name, mkId name ty id_info) : mkIdsWithGivenTys names tys id_infos
154 newLocalsWithOpenTyVarTys, newLocalsWithPolyTyVarTys :: [Name] -> NF_TcM [Id]
155 newLocalsWithOpenTyVarTys = new_locals_given_tyvar_fun newOpenTyVarTys
156 newLocalsWithPolyTyVarTys = new_locals_given_tyvar_fun newPolyTyVarTys
158 new_locals_given_tyvar_fun new_tyvar_fun names
159 = new_tyvar_fun no_of_names `thenNF_Tc` \ tys ->
160 getUniquesTc no_of_names `thenNF_Tc` \ uniqs ->
161 let ids = zipWith3 mk_local names uniqs tys in
164 no_of_names = length names
165 mk_local name uniq ty = mkUserLocal (getOccurrenceName name) uniq ty
169 @newLocal*@ creates a new unique local variable with the given
170 string and type. @newLocals@ is similar, but works on lists of strings
175 newLocalWithOpenTyVarTy, newLocalWithPolyTyVarTy :: Name -> NF_TcM Id
177 newLocalWithOpenTyVarTy name
178 = newOpenTyVarTy `thenNF_Tc` \ ty ->
179 newLocalWithGivenTy name ty
181 newLocalWithPolyTyVarTy name
182 = newPolyTyVarTy `thenNF_Tc` \ ty ->
183 newLocalWithGivenTy name ty
186 newLocalWithGivenTy :: Name -> UniType -> NF_TcM Id
187 newLocalWithGivenTy name ty
188 = getUniqueTc `thenNF_Tc` \ uniq ->
189 returnNF_Tc (mkUserLocal (getOccurrenceName name) uniq ty (getSrcLoc name))
191 newSpecPragmaId :: Name -> UniType -> Maybe SpecInfo -> NF_TcM Id
192 newSpecPragmaId name ty specinfo
193 = getUniqueTc `thenNF_Tc` \ uniq ->
194 returnNF_Tc (mkSpecPragmaId (getOccurrenceName name) uniq ty specinfo (getSrcLoc name))
196 newSpecId :: Id -> [Maybe UniType] -> UniType -> NF_TcM Id
197 newSpecId unspec spec_tys ty
198 = getUniqueTc `thenNF_Tc` \ uniq ->
199 returnNF_Tc (mkSpecId uniq unspec spec_tys ty (selectIdInfoForSpecId unspec))
202 ToDo: This @newClassOpLocals@ is used only to make new ClassOps. Pretty yukky.
205 newClassOpLocals :: [(TyVarTemplate, TauType)]
206 -- The class type variable mapped to
207 -- the instance type (an InstTyEnv)
208 -> [ClassOp] -- The class ops
209 -> NF_TcM [Id] -- Suitable Ids for the polymorphic
211 newClassOpLocals inst_env ops
212 = getSrcLocTc `thenNF_Tc` \ src_loc ->
213 getUniquesTc (length ops) `thenNF_Tc` \ uniqs ->
214 returnNF_Tc (zipWith (new_local src_loc) ops uniqs)
216 new_local src_loc op uniq
217 = mkUserLocal (getClassOpString op)
219 (instantiateTy inst_env (getClassOpLocalType op))
223 %************************************************************************
225 Back-substitution functions. These just apply the current
226 substitution to their argument(s).
228 %************************************************************************
230 @applyTcSubstAndCollectTyVars@ applies a substitution to a list of type
231 variables, takes the free type vars of the resulting types, and
232 returns all of them as list without duplications.
235 applyTcSubstAndCollectTyVars :: [TyVar] -> NF_TcM [TyVar]
236 applyTcSubstAndCollectTyVars tyvars
237 = applyTcSubstToTyVars tyvars `thenNF_Tc` \ tys ->
238 returnNF_Tc (extractTyVarsFromTys tys)
240 applyTcSubstAndExpectTyVars :: [TyVar] -> NF_TcM [TyVar]
241 applyTcSubstAndExpectTyVars tyvars
242 = applyTcSubstToTyVars tyvars `thenNF_Tc` \ tys ->
243 returnNF_Tc (map (getTyVar "applyTcSubstAndExpectTyVars") tys)