-instance Outputable (Inst s) where
- ppr sty (LitInst uniq lit ty orig loc)
- = ppHang (ppSep [case lit of
- OverloadedIntegral i -> ppInteger i
- OverloadedFractional f -> ppRational f,
- ppStr "at",
- ppr sty ty,
- show_uniq sty uniq
- ])
- 4 (show_origin sty orig)
-
- ppr sty (Dict uniq clas ty orig loc)
- = ppHang (ppSep [ppr sty clas,
- ppStr "at",
- ppr sty ty,
- show_uniq sty uniq
- ])
- 4 (show_origin sty orig)
-
- ppr sty (Method uniq id tys rho orig loc)
- = ppHang (ppSep [ppr sty id,
- ppStr "at",
- ppr sty tys,
- show_uniq sty uniq
- ])
- 4 (show_origin sty orig)
-
-show_uniq PprDebug uniq = ppr PprDebug uniq
-show_uniq sty uniq = ppNil
-
-show_origin sty orig = ppBesides [ppLparen, pprOrigin sty orig, ppRparen]
+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)