X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcClassDcl.lhs;h=c28bce15cc561b645fc23a7936c8d9161c623391;hb=1fb1ab5d53a09607e7f6d2450806760688396387;hp=fea81a43da4da9e2e61f3dcfdb07f611be4ae345;hpb=f7ecf7234c224489be8a5e63fced903b655d92ee;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index fea81a4..c28bce1 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -10,37 +10,40 @@ module TcClassDcl ( tcClassDecl1, tcClassDecls2 ) where IMP_Ubiq() -import HsSyn ( ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..), - Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..), - HsLit(..), OutPat(..), Sig(..), PolyType(..), MonoType, - Stmt, Qualifier, ArithSeqInfo, InPat, Fake ) +import HsSyn ( HsDecl(..), ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..), + Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..), + DefaultDecl, TyDecl, InstDecl, IfaceSig, Fixity, + HsLit(..), OutPat(..), Sig(..), HsType(..), HsTyVar, + Stmt, DoOrListComp, ArithSeqInfo, InPat, Fake ) +import HsTypes ( getTyVarName ) import HsPragmas ( ClassPragmas(..) ) import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..), RenamedClassOpSig(..), SYN_IE(RenamedMonoBinds), - RenamedGenPragmas(..), RenamedContext(..), - RnName{-instance Uniquable-} + RenamedGenPragmas(..), RenamedContext(..), SYN_IE(RenamedHsDecl) ) import TcHsSyn ( TcIdOcc(..), SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds), SYN_IE(TcExpr), mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, tcIdType ) import Inst ( Inst, InstOrigin(..), SYN_IE(LIE), emptyLIE, plusLIE, newDicts, newMethod ) -import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds, tcExtendGlobalTyVars ) +import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds, tcAddImportedIdInfo, + tcExtendGlobalTyVars ) import TcInstDcls ( processInstBinds ) import TcKind ( unifyKind, TcKind ) -import TcMonad hiding ( rnMtoTcM ) -import TcMonoType ( tcPolyType, tcMonoType, tcContext ) +import TcMonad +import TcMonoType ( tcHsType, tcContext ) import TcSimplify ( tcSimplifyAndCheck ) import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), tcInstType, tcInstSigTyVars, tcInstSigType ) import Bag ( foldBag, unionManyBags ) -import Class ( GenClass, mkClass, mkClassOp, classBigSig, +import Class ( GenClass, GenClassOp, mkClass, mkClassOp, classBigSig, classOps, classOpString, classOpLocalType, - classOpTagByString, SYN_IE(ClassOp) + classOpTagByOccName, SYN_IE(ClassOp) ) -import Id ( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId, +import Id ( GenId, mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId, getIdUnfolding, idType ) +import CoreUnfold ( getUnfoldingTemplate ) import IdInfo -import Name ( isLocallyDefined, origName, getLocalName ) +import Name ( Name, isLocallyDefined, moduleString, modAndOcc, nameString ) import PrelVals ( nO_DEFAULT_METHOD_ERROR_ID ) import PprStyle import Pretty @@ -57,7 +60,7 @@ import Util -- import TcPragmas ( tcGenPragmas, tcClassOpPragmas ) tcGenPragmas ty id ps = returnNF_Tc noIdInfo -tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo `addInfo` spec, +tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo `addSpecInfo` spec, noIdInfo) \end{code} @@ -104,8 +107,8 @@ tcClassDecl1 rec_inst_mapper tcAddErrCtxt (classDeclCtxt class_name) $ -- LOOK THINGS UP IN THE ENVIRONMENT - tcLookupClass class_name `thenNF_Tc` \ (class_kind, rec_class) -> - tcLookupTyVar tyvar_name `thenNF_Tc` \ (tyvar_kind, rec_tyvar) -> + tcLookupClass class_name `thenTc` \ (class_kind, rec_class) -> + tcLookupTyVar (getTyVarName tyvar_name) `thenNF_Tc` \ (tyvar_kind, rec_tyvar) -> let (rec_class_inst_env, rec_class_op_inst_fn) = rec_inst_mapper rec_class in @@ -175,41 +178,22 @@ tcClassContext rec_class rec_tyvar context pragmas in -- Make super-class selector ids - mapTc (mk_super_id rec_class) - (super_classes `zip` maybe_pragmas) `thenTc` \ sc_sel_ids -> - -- NB: we worry about matching list lengths below + mapTc (mk_super_id rec_class) super_classes `thenTc` \ sc_sel_ids -> -- Done returnTc (super_classes, sc_sel_ids) where - mk_super_id rec_class (super_class, maybe_pragma) - = fixTc ( \ rec_super_id -> - tcGetUnique `thenNF_Tc` \ uniq -> - - -- GET THE PRAGMA INFO FOR THE SUPERCLASS - (case maybe_pragma of - Nothing -> returnNF_Tc noIdInfo - Just prag -> tcGenPragmas Nothing{-ty unknown-} rec_super_id prag - ) `thenNF_Tc` \ id_info -> - let - rec_tyvar_ty = mkTyVarTy rec_tyvar + rec_tyvar_ty = mkTyVarTy rec_tyvar + + mk_super_id rec_class super_class + = tcGetUnique `thenNF_Tc` \ uniq -> + let ty = mkForAllTy rec_tyvar $ mkFunTy (mkDictTy rec_class rec_tyvar_ty) (mkDictTy super_class rec_tyvar_ty) - in - -- BUILD THE SUPERCLASS ID - returnTc (mkSuperDictSelId uniq rec_class super_class ty id_info) - ) - - maybe_pragmas :: [Maybe RenamedGenPragmas] - maybe_pragmas = case pragmas of - NoClassPragmas -> repeat Nothing - SuperDictPragmas prags -> ASSERT(length prags == length context) - map Just prags - -- If there are any pragmas there should - -- be one for each superclass - + in + returnTc (mkSuperDictSelId uniq rec_class super_class ty) tcClassSig :: Class -- Knot tying only! @@ -221,9 +205,9 @@ tcClassSig :: Class -- Knot tying only! Id) -- default-method ids tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn - (ClassOpSig op_name + (ClassOpSig op_name dm_name op_ty - pragmas src_loc) + src_loc) = tcAddSrcLoc src_loc $ fixTc ( \ ~(_, rec_sel_id, rec_defm_id) -> -- Knot for pragmas @@ -232,33 +216,25 @@ tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn -- NB: Renamer checks that the class type variable is mentioned in local_ty, -- and that it is not constrained by theta - tcPolyType op_ty `thenTc` \ local_ty -> + tcHsType op_ty `thenTc` \ local_ty -> let global_ty = mkSigmaTy [rec_clas_tyvar] [(rec_clas, mkTyVarTy rec_clas_tyvar)] local_ty - class_op_nm = getLocalName op_name + class_op_nm = getOccName op_name class_op = mkClassOp class_op_nm - (classOpTagByString rec_clas{-yeeps!-} class_op_nm) + (classOpTagByOccName rec_clas{-yeeps!-} class_op_nm) local_ty in - -- Munch the pragmas - tcClassOpPragmas - global_ty - rec_sel_id rec_defm_id - (rec_classop_spec_fn class_op) - pragmas `thenNF_Tc` \ (op_info, defm_info) -> - -- Build the selector id and default method id - tcGetUnique `thenNF_Tc` \ d_uniq -> let - op_uniq = uniqueOf op_name - sel_id = mkMethodSelId op_uniq rec_clas class_op global_ty op_info - defm_id = mkDefaultMethodId d_uniq rec_clas class_op False global_ty defm_info + sel_id = mkMethodSelId op_name rec_clas class_op global_ty + defm_id = mkDefaultMethodId dm_name rec_clas class_op False global_ty -- ToDo: improve the "False" in - returnTc (class_op, sel_id, defm_id) + tcAddImportedIdInfo defm_id `thenNF_Tc` \ final_defm_id -> + returnTc (class_op, sel_id, final_defm_id) ) \end{code} @@ -286,14 +262,13 @@ The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to each local class decl. \begin{code} -tcClassDecls2 :: Bag RenamedClassDecl +tcClassDecls2 :: [RenamedHsDecl] -> NF_TcM s (LIE s, TcHsBinds s) tcClassDecls2 decls - = foldBag combine - tcClassDecl2 - (returnNF_Tc (emptyLIE, EmptyBinds)) - decls + = foldr combine + (returnNF_Tc (emptyLIE, EmptyBinds)) + [tcClassDecl2 cls_decl | ClD cls_decl <- decls] where combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) -> tc2 `thenNF_Tc` \ (lie2, binds2) -> @@ -318,17 +293,20 @@ tcClassDecl2 (ClassDecl context class_name tcAddSrcLoc src_loc $ -- Get the relevant class - tcLookupClass class_name `thenNF_Tc` \ (_, clas) -> + tcLookupClass class_name `thenTc` \ (_, clas) -> let (tyvar, scs, sc_sel_ids, ops, op_sel_ids, defm_ids) = classBigSig clas + + -- The selector binds are already in the selector Id's unfoldings + sel_binds = SingleBind $ NonRecBind $ foldr AndMonoBinds EmptyMonoBinds $ + [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id)) + | sel_id <- sc_sel_ids ++ op_sel_ids, + isLocallyDefined sel_id + ] in + -- Generate bindings for the default methods tcInstSigTyVars [tyvar] `thenNF_Tc` \ ([clas_tyvar], _, _) -> - - -- Generate bindings for the selector functions - buildSelectors clas tyvar clas_tyvar scs sc_sel_ids ops op_sel_ids - `thenNF_Tc` \ sel_binds -> - -- Ditto for the methods buildDefaultMethodBinds clas clas_tyvar defm_ids default_binds `thenTc` \ (const_insts, meth_binds) -> @@ -337,134 +315,6 @@ tcClassDecl2 (ClassDecl context class_name %************************************************************************ %* * -\subsection[ClassDcl-bld-sels]{Building the selector functions for methods and superclasses} -%* * -%************************************************************************ - -\begin{code} -buildSelectors :: Class -- The class object - -> TyVar -- Class type variable - -> TcTyVar s -- Instantiated class type variable (TyVarTy) - -> [Class] -> [Id] -- Superclasses and selectors - -> [ClassOp] -> [Id] -- Class ops and selectors - -> NF_TcM s (TcHsBinds s) - -buildSelectors clas clas_tyvar clas_tc_tyvar scs sc_sel_ids ops op_sel_ids - = - -- Make new Ids for the components of the dictionary - let - clas_tyvar_ty = mkTyVarTy clas_tc_tyvar - mk_op_ty = tcInstType [(clas_tyvar, clas_tyvar_ty)] . classOpLocalType - in - mapNF_Tc mk_op_ty ops `thenNF_Tc` \ op_tys -> - newLocalIds (map classOpString ops) op_tys `thenNF_Tc` \ method_ids -> - - newDicts ClassDeclOrigin - [ (super_clas, clas_tyvar_ty) - | super_clas <- scs ] `thenNF_Tc` \ (_,dict_ids) -> - - newDicts ClassDeclOrigin - [ (clas, clas_tyvar_ty) ] `thenNF_Tc` \ (_,[clas_dict]) -> - - -- Make suitable bindings for the selectors - let - mk_sel sel_id method_or_dict - = mkSelBind sel_id clas_tc_tyvar clas_dict dict_ids method_ids method_or_dict - in - listNF_Tc (zipWithEqual "mk_sel1" mk_sel op_sel_ids method_ids) `thenNF_Tc` \ op_sel_binds -> - listNF_Tc (zipWithEqual "mk_sel2" mk_sel sc_sel_ids dict_ids) `thenNF_Tc` \ sc_sel_binds -> - - returnNF_Tc (SingleBind ( - NonRecBind ( - foldr AndMonoBinds - (foldr AndMonoBinds EmptyMonoBinds op_sel_binds) - sc_sel_binds - ))) -\end{code} - -%************************************************************************ -%* * -\subsection[ClassDcl-misc]{Miscellaneous} -%* * -%************************************************************************ - -Make a selector expression for @sel_id@ from a dictionary @clas_dict@ -consisting of @dicts@ and @methods@. - -====================== OLD ============================ -We have to do a bit of jiggery pokery to get the type variables right. -Suppose we have the class decl: -\begin{verbatim} - class Foo a where - op1 :: Ord b => a -> b -> a - op2 :: ... -\end{verbatim} -Then the method selector for \tr{op1} is like this: -\begin{verbatim} - op1_sel = /\a b -> \dFoo dOrd -> case dFoo of - (op1_method,op2_method) -> op1_method b dOrd -\end{verbatim} -Note that the type variable for \tr{b} and the (Ord b) dictionary -are lifted to the top lambda, and -\tr{op1_method} is applied to them. This is preferable to the alternative: -\begin{verbatim} - op1_sel' = /\a -> \dFoo -> case dFoo of - (op1_method,op2_method) -> op1_method -\end{verbatim} -because \tr{op1_sel'} then has the rather strange type -\begin{verbatim} - op1_sel' :: forall a. Foo a -> forall b. Ord b -> a -> b -> a -\end{verbatim} -whereas \tr{op1_sel} (the one we use) has the decent type -\begin{verbatim} - op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a -\end{verbatim} -========================= END OF OLD =========================== - -NEW COMMENT: instead we now go for op1_sel' above. Seems tidier and -the rest of the compiler darn well ought to cope. - - - -NOTE that we return a TcMonoBinds (which is later zonked) even though -there's no real back-substitution to do. It's just simpler this way! - -NOTE ALSO that the selector has no free type variables, so we -don't bother to instantiate the class-op's local type; instead -we just use the variables inside it. - -\begin{code} -mkSelBind :: Id -- the selector id - -> TcTyVar s -> TcIdOcc s -- class tyvar and dict - -> [TcIdOcc s] -> [TcIdOcc s] -- superclasses and methods in class dict - -> TcIdOcc s -- the superclass/method being slected - -> NF_TcM s (TcMonoBinds s) - -mkSelBind sel_id clas_tyvar clas_dict dicts methods method_or_dict@(TcId op) - = - -- sel_id = /\ clas_tyvar -> \ clas_dict -> - -- case clas_dict of - -- -> method_or_dict - - returnNF_Tc (VarMonoBind (RealId sel_id) ( - TyLam [clas_tyvar] ( - DictLam [clas_dict] ( - HsCase - (HsVar clas_dict) - ([PatMatch (DictPat dicts methods) ( - GRHSMatch (GRHSsAndBindsOut - [OtherwiseGRHS - (HsVar method_or_dict) - mkGeneratedSrcLoc] - EmptyBinds - (idType op)))]) - mkGeneratedSrcLoc - )))) -\end{code} - - -%************************************************************************ -%* * \subsection[Default methods]{Default methods} %* * %************************************************************************ @@ -582,6 +432,72 @@ buildDefaultMethodBinds clas clas_tyvar origin = ClassDeclOrigin \end{code} +==================== +buildDefaultMethodBinds + :: Class + -> TcTyVar s + -> [Id] + -> RenamedMonoBinds + -> TcM s (LIE s, TcHsBinds s) + +buildDefaultMethodBinds clas clas_tyvar + default_method_ids default_binds + = newDicts origin [(clas,inst_ty)] `thenNF_Tc` \ (this_dict, [this_dict_id]) -> + tcExtendGlobalTyVars clas_tyvar_set ( + tcDefaultMethodBinds default_binds + ) + +tcDefaultMethodBinds default_meth_ids default_binds + where + go (AndMonoBinds b1 b2) + = go b1 `thenTc` \ (new_b1, lie1) -> + go b2 `thenTc` \ (new_b2, lie2) -> + returnTc (new_b1 `ThenBinds` new_b2, lie1 `plusLIE` lie2) + + go EmptyMonoBinds = EmptyBinds + + go mbind = processInstBinds1 clas clas_dict meth_ids mbind `thenTc` \ (tags + +tcDefaultMethodBinds EmptyMonoBinds + + + + processInstBinds + clas + (makeClassDeclDefaultMethodRhs clas local_defm_ids) + avail_insts + local_defm_ids + default_binds + ) `thenTc` \ (insts_needed, default_binds') -> + + let + mapAndUnzipNF_Tc mk_method default_method_ids `thenNF_Tc` \ (insts_s, local_defm_ids) -> + let + avail_insts = this_dict `plusLIE` unionManyBags insts_s -- Insts available + clas_tyvar_set = unitTyVarSet clas_tyvar + in + + tcSimplifyAndCheck + clas_tyvar_set + avail_insts + insts_needed `thenTc` \ (const_lie, dict_binds) -> + + + let + defm_binds = AbsBinds + [clas_tyvar] + [this_dict_id] + (local_defm_ids `zip` map RealId default_method_ids) + dict_binds + (RecBind default_binds') + in + returnTc (const_lie, defm_binds) + where + inst_ty = mkTyVarTy clas_tyvar + mk_method defm_id = newMethod origin (RealId defm_id) [inst_ty] + origin = ClassDeclOrigin +================== + @makeClassDeclDefaultMethodRhs@ builds the default method for a class declaration when no explicit default method is given. @@ -601,28 +517,15 @@ makeClassDeclDefaultMethodRhs clas method_ids tag returnNF_Tc (HsApp (mkHsTyApp (HsVar (RealId nO_DEFAULT_METHOD_ERROR_ID)) [tcIdType method_id]) (HsLitOut (HsString (_PK_ error_msg)) stringTy)) -{- OLD AND COMPLICATED - tcInstSigType () `thenNF_Tc` \ method_ty -> - let - (tyvars, theta, tau) = splitSigmaTy method_ty - in - newDicts ClassDeclOrigin theta `thenNF_Tc` \ (lie, dict_ids) -> - - returnNF_Tc (mkHsTyLam tyvars ( - mkHsDictLam dict_ids ( - HsApp (mkHsTyApp (HsVar (RealId nO_DEFAULT_METHOD_ERROR_ID)) [tau]) - (HsLitOut (HsString (_PK_ error_msg)) stringTy)))) --} - where - (OrigName clas_mod clas_name) = origName "makeClassDeclDefaultMethodRhs" clas + (clas_mod, clas_name) = modAndOcc clas method_id = method_ids !! (tag-1) class_op = (classOps clas) !! (tag-1) - error_msg = _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "." + error_msg = _UNPK_ (nameString (getName clas)) ++ (ppShow 80 (ppr PprForUser class_op)) - ++ "\"" +-- ++ "\"" Don't know what this trailing quote is for! \end{code} @@ -630,5 +533,5 @@ Contexts ~~~~~~~~ \begin{code} classDeclCtxt class_name sty - = ppCat [ppStr "In the class declaration for", ppr sty class_name] + = ppCat [ppPStr SLIT("In the class declaration for"), ppr sty class_name] \end{code}