X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FInst.lhs;h=a24e7acd1a9b1229d33f55c87e03ca8704e153ba;hb=ca5a4a480d10d61e5b7a52eb4d556e8b8c33e69d;hp=7ad462e45cc6954c2b99cac883de2f12523451e0;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 7ad462e..a24e7ac 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -10,7 +10,7 @@ module Inst ( Inst(..), -- Visible only to TcSimplify InstOrigin(..), OverloadedLit(..), - LIE(..), emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, + LIE(..), emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, plusLIEs, InstanceMapper(..), @@ -36,21 +36,21 @@ import RnHsSyn ( RenamedArithSeqInfo(..), RenamedHsExpr(..) ) import TcHsSyn ( TcIdOcc(..), TcExpr(..), TcIdBndr(..), mkHsTyApp, mkHsDictApp ) -import TcMonad +import TcMonad hiding ( rnMtoTcM ) import TcEnv ( tcLookupGlobalValueByKey ) import TcType ( TcType(..), TcRhoType(..), TcMaybe, TcTyVarSet(..), tcInstType, tcInstTcType, zonkTcType ) -import Bag ( Bag, emptyBag, unitBag, unionBags, listToBag, consBag ) -import Class ( Class(..), GenClass, ClassInstEnv(..), getClassInstEnv ) +import Bag ( emptyBag, unitBag, unionBags, unionManyBags, listToBag, consBag ) +import Class ( Class(..), GenClass, ClassInstEnv(..), classInstEnv ) import Id ( GenId, idType, mkInstId ) import MatchEnv ( lookupMEnv, insertMEnv ) -import Name ( Name ) -import NameTypes( ShortName, mkShortName ) +import Name ( mkLocalName, getLocalName, Name ) import Outputable import PprType ( GenClass, TyCon, GenType, GenTyVar ) import PprStyle ( PprStyle(..) ) import Pretty +import RnHsSyn ( RnName{-instance NamedThing-} ) import SpecEnv ( SpecEnv(..) ) import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) import Type ( GenType, eqSimpleTy, @@ -78,6 +78,7 @@ emptyLIE = emptyBag unitLIE inst = unitBag inst plusLIE lie1 lie2 = lie1 `unionBags` lie2 consLIE inst lie = inst `consBag` lie +plusLIEs lies = unionManyBags lies zonkLIE :: LIE s -> NF_TcM s (LIE s) zonkLIE lie = mapBagNF_Tc zonkInst lie @@ -153,86 +154,85 @@ newDicts :: InstOrigin s -> [(Class, TcType s)] -> NF_TcM s (LIE s, [TcIdOcc s]) newDicts orig theta - = tcGetSrcLoc `thenNF_Tc` \ loc -> - tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs -> - let + = tcGetSrcLoc `thenNF_Tc` \ loc -> + tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs -> + let mk_dict u (clas, ty) = Dict u clas ty orig loc dicts = zipWithEqual mk_dict new_uniqs theta - in - returnNF_Tc (listToBag dicts, map instToId dicts) + in + returnNF_Tc (listToBag dicts, map instToId dicts) newDictsAtLoc orig loc theta -- Local function, similar to newDicts, -- but with slightly different interface - = tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs -> - let + = tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs -> + let mk_dict u (clas, ty) = Dict u clas ty orig loc dicts = zipWithEqual mk_dict new_uniqs theta - in - returnNF_Tc (dicts, map instToId dicts) + in + returnNF_Tc (dicts, map instToId dicts) newMethod :: InstOrigin s -> TcIdOcc s -> [TcType s] -> NF_TcM s (LIE s, TcIdOcc s) newMethod orig id tys - = -- Get the Id type and instantiate it at the specified types - (case id of - RealId id -> let (tyvars, rho) = splitForAllTy (idType id) - in tcInstType (tyvars `zipEqual` tys) rho - TcId id -> let (tyvars, rho) = splitForAllTy (idType id) - in tcInstTcType (tyvars `zipEqual` tys) rho - ) `thenNF_Tc` \ rho_ty -> - - -- Our friend does the rest - newMethodWithGivenTy orig id tys rho_ty + = -- Get the Id type and instantiate it at the specified types + (case id of + RealId id -> let (tyvars, rho) = splitForAllTy (idType id) + in tcInstType (tyvars `zipEqual` tys) rho + TcId id -> let (tyvars, rho) = splitForAllTy (idType id) + in tcInstTcType (tyvars `zipEqual` tys) rho + ) `thenNF_Tc` \ rho_ty -> + -- Our friend does the rest + newMethodWithGivenTy orig id tys rho_ty newMethodWithGivenTy orig id tys rho_ty - = tcGetSrcLoc `thenNF_Tc` \ loc -> - tcGetUnique `thenNF_Tc` \ new_uniq -> - let + = tcGetSrcLoc `thenNF_Tc` \ loc -> + tcGetUnique `thenNF_Tc` \ new_uniq -> + let meth_inst = Method new_uniq id tys rho_ty orig loc - in - returnNF_Tc (unitLIE meth_inst, instToId meth_inst) + in + returnNF_Tc (unitLIE meth_inst, instToId meth_inst) newMethodAtLoc :: InstOrigin s -> SrcLoc -> Id -> [TcType s] -> NF_TcM s (Inst s, TcIdOcc s) newMethodAtLoc orig 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 - let - (tyvars,rho) = splitForAllTy (idType real_id) - in - tcInstType (tyvars `zipEqual` tys) rho `thenNF_Tc` \ rho_ty -> - tcGetUnique `thenNF_Tc` \ new_uniq -> - let + = -- Get the Id type and instantiate it at the specified types + let + (tyvars,rho) = splitForAllTy (idType real_id) + in + tcInstType (tyvars `zipEqual` tys) rho `thenNF_Tc` \ rho_ty -> + tcGetUnique `thenNF_Tc` \ new_uniq -> + let meth_inst = Method new_uniq (RealId real_id) tys rho_ty orig loc - in - returnNF_Tc (meth_inst, instToId meth_inst) + in + returnNF_Tc (meth_inst, instToId meth_inst) newOverloadedLit :: InstOrigin s -> OverloadedLit -> TcType s -> NF_TcM s (LIE s, TcIdOcc s) newOverloadedLit orig lit ty - = tcGetSrcLoc `thenNF_Tc` \ loc -> - tcGetUnique `thenNF_Tc` \ new_uniq -> - let + = tcGetSrcLoc `thenNF_Tc` \ loc -> + tcGetUnique `thenNF_Tc` \ new_uniq -> + let lit_inst = LitInst new_uniq lit ty orig loc - in - returnNF_Tc (unitLIE lit_inst, instToId lit_inst) + in + returnNF_Tc (unitLIE lit_inst, instToId lit_inst) \end{code} \begin{code} instToId :: Inst s -> TcIdOcc s -instToId (Dict uniq clas ty orig loc) - = TcId (mkInstId uniq (mkDictTy clas ty) (mkShortName SLIT("dict") loc)) -instToId (Method uniq id tys rho_ty orig loc) - = TcId (mkInstId uniq tau_ty (mkShortName (getOccurrenceName id) loc)) +instToId (Dict u clas ty orig loc) + = TcId (mkInstId u (mkDictTy clas ty) (mkLocalName u SLIT("dict") loc)) +instToId (Method u id tys rho_ty orig loc) + = TcId (mkInstId u tau_ty (mkLocalName u (getLocalName id) loc)) where (_, tau_ty) = splitRhoTy rho_ty -- NB The method Id has just the tau type -instToId (LitInst uniq list ty orig loc) - = TcId (mkInstId uniq ty (mkShortName SLIT("lit") loc)) +instToId (LitInst u list ty orig loc) + = TcId (mkInstId u ty (mkLocalName u SLIT("lit") loc)) \end{code} \begin{code} @@ -251,18 +251,18 @@ need, and it's a lot of extra work. \begin{code} zonkInst :: Inst s -> NF_TcM s (Inst s) -zonkInst (Dict uniq clas ty orig loc) +zonkInst (Dict u clas ty orig loc) = zonkTcType ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (Dict uniq clas new_ty orig loc) + returnNF_Tc (Dict u clas new_ty orig loc) -zonkInst (Method uniq id tys rho orig loc) -- Doesn't zonk the id! +zonkInst (Method u id tys rho orig loc) -- Doesn't zonk the id! = mapNF_Tc zonkTcType tys `thenNF_Tc` \ new_tys -> zonkTcType rho `thenNF_Tc` \ new_rho -> - returnNF_Tc (Method uniq id new_tys new_rho orig loc) + returnNF_Tc (Method u id new_tys new_rho orig loc) -zonkInst (LitInst uniq lit ty orig loc) +zonkInst (LitInst u lit ty orig loc) = zonkTcType ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (LitInst uniq lit new_ty orig loc) + returnNF_Tc (LitInst u lit new_ty orig loc) \end{code} @@ -341,35 +341,31 @@ relevant in error messages. \begin{code} instance Outputable (Inst s) where ppr sty (LitInst uniq lit ty orig loc) - = ppHang (ppSep [case lit of + = 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) + ppStr "at", + ppr sty ty, + show_uniq sty uniq + ] 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) + = ppSep [ppr sty clas, + ppStr "at", + ppr sty ty, + show_uniq sty uniq + ] 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) + = ppSep [ppr sty id, + ppStr "at", + ppr sty tys, + show_uniq sty uniq + ] show_uniq PprDebug uniq = ppr PprDebug uniq show_uniq sty uniq = ppNil -show_origin sty orig = ppBesides [ppLparen, pprOrigin sty orig, ppRparen] \end{code} Printing in error messages @@ -412,7 +408,9 @@ lookupInst :: Inst s lookupInst dict@(Dict _ clas ty orig loc) = case lookupMEnv matchTy (get_inst_env clas orig) ty of - Nothing -> failTc (noInstanceErr dict) + Nothing -> tcAddSrcLoc loc $ + tcAddErrCtxt (pprOrigin orig) $ + failTc (noInstanceErr dict) Just (dfun_id, tenv) -> let @@ -472,7 +470,7 @@ ambiguous dictionaries. lookupClassInstAtSimpleType :: Class -> Type -> Maybe Id lookupClassInstAtSimpleType clas ty - = case (lookupMEnv matchTy (getClassInstEnv clas) ty) of + = case (lookupMEnv matchTy (classInstEnv clas) ty) of Nothing -> Nothing Just (dfun,_) -> ASSERT( null tyvars && null theta ) Just dfun @@ -498,7 +496,7 @@ mkInstSpecEnv :: Class -- class mkInstSpecEnv clas inst_ty inst_tvs inst_theta = mkSpecEnv (catMaybes (map maybe_spec_info matches)) where - matches = matchMEnv matchTy (getClassInstEnv clas) inst_ty + matches = matchMEnv matchTy (classInstEnv clas) inst_ty maybe_spec_info (_, match_info, MkInstTemplate dfun _ []) = Just (SpecInfo (map (assocMaybe match_info) inst_tvs) (length inst_theta) dfun) @@ -537,6 +535,10 @@ data InstOrigin s = OccurrenceOf (TcIdOcc s) -- Occurrence of an overloaded identifier | OccurrenceOfCon Id -- Occurrence of a data constructor + | RecordUpdOrigin + + | DataDeclOrigin -- Typechecking a data declaration + | InstanceDeclOrigin -- Typechecking an instance decl | LiteralOrigin HsLit -- Occurrence of a literal @@ -596,52 +598,52 @@ get_inst_env clas (DerivingOrigin inst_mapper _ _) = fst (inst_mapper clas) get_inst_env clas (InstanceSpecOrigin inst_mapper _ _) = fst (inst_mapper clas) -get_inst_env clas other_orig = getClassInstEnv clas +get_inst_env clas other_orig = classInstEnv clas -pprOrigin :: PprStyle -> InstOrigin s -> Pretty +pprOrigin :: InstOrigin s -> PprStyle -> Pretty -pprOrigin sty (OccurrenceOf id) +pprOrigin (OccurrenceOf id) sty = ppBesides [ppPStr SLIT("at a use of an overloaded identifier: `"), ppr sty id, ppChar '\''] -pprOrigin sty (OccurrenceOfCon id) +pprOrigin (OccurrenceOfCon id) sty = ppBesides [ppPStr SLIT("at a use of an overloaded constructor: `"), ppr sty id, ppChar '\''] -pprOrigin sty (InstanceDeclOrigin) +pprOrigin (InstanceDeclOrigin) sty = ppStr "in an instance declaration" -pprOrigin sty (LiteralOrigin lit) +pprOrigin (LiteralOrigin lit) sty = ppCat [ppStr "at an overloaded literal:", ppr sty lit] -pprOrigin sty (ArithSeqOrigin seq) +pprOrigin (ArithSeqOrigin seq) sty = ppCat [ppStr "at an arithmetic sequence:", ppr sty seq] -pprOrigin sty (SignatureOrigin) +pprOrigin (SignatureOrigin) sty = ppStr "in a type signature" -pprOrigin sty (DoOrigin) +pprOrigin (DoOrigin) sty = ppStr "in a do statement" -pprOrigin sty (ClassDeclOrigin) +pprOrigin (ClassDeclOrigin) sty = ppStr "in a class declaration" -pprOrigin sty (DerivingOrigin _ clas tycon) +pprOrigin (DerivingOrigin _ clas tycon) sty = ppBesides [ppStr "in a `deriving' clause; class `", ppr sty clas, ppStr "'; offending type `", ppr sty tycon, ppStr "'"] -pprOrigin sty (InstanceSpecOrigin _ clas ty) +pprOrigin (InstanceSpecOrigin _ clas ty) sty = ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"", ppr sty clas, ppStr "\" type: ", ppr sty ty] -pprOrigin sty (DefaultDeclOrigin) +pprOrigin (DefaultDeclOrigin) sty = ppStr "in a `default' declaration" -pprOrigin sty (ValSpecOrigin name) +pprOrigin (ValSpecOrigin name) sty = ppBesides [ppStr "in a SPECIALIZE user-pragma for `", ppr sty name, ppStr "'"] -pprOrigin sty (CCallOrigin clabel Nothing{-ccall result-}) +pprOrigin (CCallOrigin clabel Nothing{-ccall result-}) sty = ppBesides [ppStr "in the result of the _ccall_ to `", ppStr clabel, ppStr "'"] -pprOrigin sty (CCallOrigin clabel (Just arg_expr)) +pprOrigin (CCallOrigin clabel (Just arg_expr)) sty = ppBesides [ppStr "in an argument in the _ccall_ to `", ppStr clabel, ppStr "', namely: ", ppr sty arg_expr] -pprOrigin sty (LitLitOrigin s) +pprOrigin (LitLitOrigin s) sty = ppBesides [ppStr "in this ``literal-literal'': ", ppStr s] -pprOrigin sty UnknownOrigin +pprOrigin UnknownOrigin sty = ppStr "in... oops -- I don't know where the overloading came from!" \end{code}