-instance Outputable (Inst s) where
- ppr sty inst = ppr_inst sty ppNil (\ o l -> ppNil) inst
-
-pprInst sty hdr inst = ppr_inst sty hdr (\ o l -> pprOrigin hdr o l sty) inst
-
-ppr_inst sty hdr ppr_orig (LitInst u lit ty orig loc)
- = ppHang (ppr_orig orig loc)
- 4 (ppCat [case lit of
- OverloadedIntegral i -> ppInteger i
- OverloadedFractional f -> ppRational f,
- ppStr "at",
- ppr sty ty,
- show_uniq sty u])
-
-ppr_inst sty hdr ppr_orig (Dict u clas ty orig loc)
- = ppHang (ppr_orig orig loc)
- 4 (ppCat [ppr sty clas, ppr sty ty, show_uniq sty u])
-
-ppr_inst sty hdr ppr_orig (Method u id tys rho orig loc)
- = ppHang (ppr_orig orig loc)
- 4 (ppCat [ppr sty id, ppStr "at", interppSP sty tys, show_uniq sty u])
-
-show_uniq PprDebug u = ppr PprDebug u
-show_uniq sty u = ppNil
+newDicts :: InstOrigin
+ -> TcThetaType
+ -> NF_TcM (LIE, [TcId])
+newDicts orig theta
+ = tcGetInstLoc orig `thenNF_Tc` \ loc ->
+ newDictsAtLoc loc theta `thenNF_Tc` \ (dicts, ids) ->
+ returnNF_Tc (listToBag dicts, ids)
+
+newClassDicts :: InstOrigin
+ -> [(Class,[TcType])]
+ -> NF_TcM (LIE, [TcId])
+newClassDicts orig theta
+ = newDicts orig (map (uncurry Class) theta)
+
+-- Local function, similar to newDicts,
+-- but with slightly different interface
+newDictsAtLoc :: InstLoc
+ -> TcThetaType
+ -> NF_TcM ([Inst], [TcId])
+newDictsAtLoc loc theta =
+ tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
+ let
+ mk_dict u pred = Dict u pred loc
+ dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
+ in
+ returnNF_Tc (dicts, map instToId dicts)
+
+newDictFromOld :: Inst -> Class -> [TcType] -> NF_TcM Inst
+newDictFromOld (Dict _ _ loc) clas tys
+ = tcGetUnique `thenNF_Tc` \ uniq ->
+ returnNF_Tc (Dict uniq (Class clas tys) loc)
+
+
+newMethod :: InstOrigin
+ -> TcId
+ -> [TcType]
+ -> NF_TcM (LIE, TcId)
+newMethod orig id tys
+ = -- Get the Id type and instantiate it at the specified types
+ let
+ (tyvars, rho) = splitForAllTys (idType id)
+ rho_ty = substTy (mkTyVarSubst tyvars tys) rho
+ (theta, tau) = splitRhoTy rho_ty
+ in
+ newMethodWithGivenTy orig id tys theta tau `thenNF_Tc` \ meth_inst ->
+ returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
+
+instOverloadedFun orig v arg_tys theta tau
+-- This is where we introduce new functional dependencies into the LIE
+ = newMethodWithGivenTy orig v arg_tys theta tau `thenNF_Tc` \ inst ->
+ instFunDeps orig theta `thenNF_Tc` \ fds ->
+ returnNF_Tc (instToId inst, mkLIE (inst : fds))
+
+instFunDeps orig theta
+ = tcGetUnique `thenNF_Tc` \ uniq ->
+ tcGetInstLoc orig `thenNF_Tc` \ loc ->
+ let ifd (Class clas tys) =
+ let fds = instantiateFdClassTys clas tys in
+ if null fds then Nothing else Just (FunDep uniq clas fds loc)
+ ifd _ = Nothing
+ in returnNF_Tc (catMaybes (map ifd theta))
+
+instFunDepsOfTheta theta
+ = let ifd (Class clas tys) = instantiateFdClassTys clas tys
+ ifd (IParam n ty) = [([], [ty])]
+ in concat (map ifd theta)
+
+newMethodWithGivenTy orig id tys theta tau
+ = tcGetInstLoc orig `thenNF_Tc` \ loc ->
+ newMethodWith id tys theta tau loc
+
+newMethodWith id tys theta tau loc
+ = tcGetUnique `thenNF_Tc` \ new_uniq ->
+ returnNF_Tc (Method new_uniq id tys theta tau loc)
+
+newMethodAtLoc :: InstLoc
+ -> Id -> [TcType]
+ -> NF_TcM (Inst, TcId)
+newMethodAtLoc loc real_id tys -- Local function, similar to newMethod but with
+ -- slightly different interface
+ = -- Get the Id type and instantiate it at the specified types
+ tcGetUnique `thenNF_Tc` \ new_uniq ->
+ let
+ (tyvars,rho) = splitForAllTys (idType real_id)
+ rho_ty = ASSERT( length tyvars == length tys )
+ substTy (mkTopTyVarSubst tyvars tys) rho
+ (theta, tau) = splitRhoTy rho_ty
+ meth_inst = Method new_uniq real_id tys theta tau loc
+ in
+ returnNF_Tc (meth_inst, instToId meth_inst)