From: simonpj Date: Tue, 23 May 2000 13:16:52 +0000 (+0000) Subject: [project @ 2000-05-23 13:16:51 by simonpj] X-Git-Tag: Approximately_9120_patches~4404 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=bebb2614af8819da9298fb537d2a777743b3fabb;hp=3a68f09199fb656512347c57f4a7a4f1215a36bd;p=ghc-hetmet.git [project @ 2000-05-23 13:16:51 by simonpj] MERGE 4.07 * Fix records with polymorphic fields (broken by previous 'fix') As a tidy-up I also put a TyCon into a FieldLabel * Fix a glitch with the result-type-sig change --- diff --git a/ghc/compiler/basicTypes/FieldLabel.lhs b/ghc/compiler/basicTypes/FieldLabel.lhs index 15c7c63..50a6687 100644 --- a/ghc/compiler/basicTypes/FieldLabel.lhs +++ b/ghc/compiler/basicTypes/FieldLabel.lhs @@ -4,11 +4,20 @@ \section[FieldLabel]{The @FieldLabel@ type} \begin{code} -module FieldLabel where +module FieldLabel( + FieldLabel, -- Abstract + + mkFieldLabel, + fieldLabelName, fieldLabelTyCon, fieldLabelType, fieldLabelTag, + + FieldLabelTag, + firstFieldLabelTag, allFieldLabelTags + ) where #include "HsVersions.h" import {-# SOURCE #-} TypeRep( Type ) -- FieldLabel is compiled very early +import {-# SOURCE #-} TyCon( TyCon ) -- FieldLabel is compiled very early import Name ( Name{-instance Eq/Outputable-}, NamedThing(..), nameUnique ) import Outputable @@ -18,6 +27,9 @@ import Unique ( Uniquable(..) ) \begin{code} data FieldLabel = FieldLabel Name -- Also used as the Name of the field selector Id + + TyCon -- Parent type constructor + Type -- Type of the field; may have free type variables that -- are the tyvars of its parent *data* constructor, and -- those will be the same as the tyvars of its parent *type* constructor @@ -41,19 +53,20 @@ firstFieldLabelTag = 1 allFieldLabelTags :: [FieldLabelTag] allFieldLabelTags = [firstFieldLabelTag..] -fieldLabelName (FieldLabel n _ _) = n -fieldLabelType (FieldLabel _ ty _) = ty -fieldLabelTag (FieldLabel _ _ tag) = tag +fieldLabelName (FieldLabel n _ _ _) = n +fieldLabelTyCon (FieldLabel _ tc _ _) = tc +fieldLabelType (FieldLabel _ _ ty _) = ty +fieldLabelTag (FieldLabel _ _ _ tag) = tag instance Eq FieldLabel where - (FieldLabel n1 _ _) == (FieldLabel n2 _ _) = n1 == n2 + fl1 == fl2 = fieldLabelName fl1 == fieldLabelName fl2 instance Outputable FieldLabel where - ppr (FieldLabel n _ _) = ppr n + ppr fl = ppr (fieldLabelName fl) instance NamedThing FieldLabel where - getName (FieldLabel n _ _) = n + getName = fieldLabelName instance Uniquable FieldLabel where - getUnique (FieldLabel n _ _) = nameUnique n + getUnique fl = nameUnique (fieldLabelName fl) \end{code} diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 411c994..3206e03 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -464,7 +464,7 @@ mkDictSelId name clas where ty = exprType rhs sel_id = mkId name ty info - field_lbl = mkFieldLabel name ty tag + field_lbl = mkFieldLabel name tycon ty tag tag = assoc "MkId.mkDictSelId" (classSelIds clas `zip` allFieldLabelTags) sel_id info = mkIdInfo (RecordSelId field_lbl) diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index d67ecfd..b8250da 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -97,8 +97,16 @@ dsMonoBinds auto_scc (PatMonoBind pat grhss locn) rest mapDs (addAutoScc auto_scc) sel_binds `thenDs` \ sel_binds -> returnDs (sel_binds ++ rest) - -- Common case: one exported variable - -- All non-recursive bindings come through this way + -- Common special case: no type or dictionary abstraction +dsMonoBinds auto_scc (AbsBinds [] [] exports inlines binds) rest + = dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs -> + let + exports' = [(global, Var local) | (_, global, local) <- exports] + in + returnDs (addLocalInlines exports inlines core_prs ++ exports' ++ rest) + + -- Another common case: one exported variable + -- Non-recursive bindings come through this way dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exps@[(tyvars, global, local)] inlines binds) rest = ASSERT( all (`elem` tyvars) all_tyvars ) @@ -113,14 +121,6 @@ dsMonoBinds auto_scc in returnDs (global' : rest) - -- Another common special case: no type or dictionary abstraction -dsMonoBinds auto_scc (AbsBinds [] [] exports inlines binds) rest - = dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs -> - let - exports' = [(global, Var local) | (_, global, local) <- exports] - in - returnDs (addLocalInlines exports inlines core_prs ++ exports' ++ rest) - dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports inlines binds) rest = dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs -> let diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 342529c..92a82b5 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -675,7 +675,7 @@ tcMonoBinds mbinds tc_ty_sigs is_rec lie_avail1 `plusLIE` lie_avail2) tc_mb_pats (FunMonoBind name inf matches locn) - = newTyVarTy boxedTypeKind `thenNF_Tc` \ bndr_ty -> + = new_lhs_ty `thenNF_Tc` \ bndr_ty -> tc_pat_bndr name bndr_ty `thenTc` \ bndr_id -> let complete_it xve = tcAddSrcLoc locn $ @@ -686,13 +686,7 @@ tcMonoBinds mbinds tc_ty_sigs is_rec tc_mb_pats bind@(PatMonoBind pat grhss locn) = tcAddSrcLoc locn $ - - -- Figure out the appropriate kind for the pattern, - -- and generate a suitable type variable - (case is_rec of - Recursive -> newTyVarTy boxedTypeKind -- Recursive, so no unboxed types - NonRecursive -> newTyVarTy_OpenKind -- Non-recursive, so we permit unboxed types - ) `thenNF_Tc` \ pat_ty -> + new_lhs_ty `thenNF_Tc` \ pat_ty -> -- Now typecheck the pattern -- We don't support binding fresh type variables in the @@ -713,6 +707,12 @@ tcMonoBinds mbinds tc_ty_sigs is_rec returnTc (PatMonoBind pat' grhss' locn, lie) in returnTc (complete_it, lie_req, tvs, ids, lie_avail) + + -- Figure out the appropriate kind for the pattern, + -- and generate a suitable type variable + new_lhs_ty = case is_rec of + Recursive -> newTyVarTy boxedTypeKind -- Recursive, so no unboxed types + NonRecursive -> newTyVarTy_OpenKind -- Non-recursive, so we permit unboxed types \end{code} %************************************************************************ diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index d940d97..230a9b4 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -45,10 +45,8 @@ import TcType ( TcType, TcTauType, newTyVarTy, newTyVarTy_OpenKind, zonkTcType ) import Class ( Class ) -import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType - ) -import Id ( idType, recordSelectorFieldLabel, - isRecordSelector, +import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon ) +import Id ( idType, recordSelectorFieldLabel, isRecordSelector, Id, mkVanillaId ) import DataCon ( dataConFieldLabels, dataConSig, @@ -65,7 +63,8 @@ import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, boxedTypeKind, mkArrowKind, tidyOpenType ) -import Subst ( mkTopTyVarSubst, substClasses ) +import TyCon ( tyConTyVars ) +import Subst ( mkTopTyVarSubst, substClasses, substTy ) import UsageSPUtils ( unannotTy ) import VarSet ( emptyVarSet, unionVarSet, elemVarSet, mkVarSet ) import TyCon ( tyConDataCons ) @@ -984,25 +983,20 @@ tcDoStmts do_or_lc stmts src_loc res_ty Game plan for record bindings ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For each binding - field = value -1. look up "field", to find its selector Id, which must have type - forall a1..an. T a1 .. an -> tau - where tau is the type of the field. +1. Find the TyCon for the bindings, from the first field label. + +2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty. -2. Instantiate this type +For each binding field = value -3. Unify the (T a1 .. an) part with the "expected result type", which - is passed in. This checks that all the field labels come from the - same type. +3. Instantiate the field type (from the field label) using the type + envt from step 2. -4. Type check the value using tcArg, passing tau as the expected - argument type. +4 Type check the value using tcArg, passing the field type as + the expected argument type. This extends OK when the field types are universally quantified. -Actually, to save excessive creation of fresh type variables, -we \begin{code} tcRecordBinds @@ -1011,27 +1005,34 @@ tcRecordBinds -> TcM s (TcRecordBinds, LIE) tcRecordBinds expected_record_ty rbinds - = mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) -> + = tcLookupValue first_field_lbl_name `thenNF_Tc` \ first_sel_id -> + let + tycon = fieldLabelTyCon (recordSelectorFieldLabel first_sel_id) + in + tcInstTyVars (tyConTyVars tycon) `thenTc` \ (_, arg_tys, tenv) -> + unifyTauTy expected_record_ty + (mkTyConApp tycon arg_tys) `thenTc_` + mapAndUnzipTc (do_bind tycon tenv) rbinds `thenTc` \ (rbinds', lies) -> returnTc (rbinds', plusLIEs lies) where - do_bind (field_label, rhs, pun_flag) - = tcLookupValue field_label `thenNF_Tc` \ sel_id -> + (first_field_lbl_name, _, _) = head rbinds + + do_bind tycon tenv (field_lbl_name, rhs, pun_flag) + = tcLookupValue field_lbl_name `thenNF_Tc` \ sel_id -> + let + field_lbl = recordSelectorFieldLabel sel_id + field_ty = substTy tenv (fieldLabelType field_lbl) + in ASSERT( isRecordSelector sel_id ) -- This lookup and assertion will surely succeed, because -- we check that the fields are indeed record selectors -- before calling tcRecordBinds + ASSERT2( fieldLabelTyCon field_lbl == tycon, ppr field_lbl ) + -- The caller of tcRecordBinds has already checked + -- that all the fields come from the same type - tcInstId sel_id `thenNF_Tc` \ (_, _, tau) -> + tcPolyExpr rhs field_ty `thenTc` \ (rhs', lie, _, _, _) -> - -- Record selectors all have type - -- forall a1..an. T a1 .. an -> tau - ASSERT( maybeToBool (splitFunTy_maybe tau) ) - let - -- Selector must have type RecordType -> FieldType - Just (record_ty, field_ty) = splitFunTy_maybe tau - in - unifyTauTy expected_record_ty record_ty `thenTc_` - tcPolyExpr rhs field_ty `thenTc` \ (rhs', lie, _, _, _) -> returnTc ((sel_id, rhs', pun_flag), lie) badFields rbinds data_con diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index cf4a69d..450dad9 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -224,7 +224,7 @@ tc_con_decl_help tycon tyvars ctxt name wkr_name ex_tyvars ex_theta details field_label = case mb_f of Nothing -> [] - Just f -> [mkFieldLabel (getName f) arg_ty (head allFieldLabelTags)] + Just f -> [mkFieldLabel (getName f) tycon arg_ty (head allFieldLabelTags)] in mk_data_con [notMarkedStrict] [arg_ty] field_label @@ -236,7 +236,7 @@ tc_con_decl_help tycon tyvars ctxt name wkr_name ex_tyvars ex_theta details arg_stricts = [strict | (_, _, strict) <- field_label_infos] arg_tys = [ty | (_, ty, _) <- field_label_infos] - field_labels = [ mkFieldLabel (getName name) ty tag + field_labels = [ mkFieldLabel (getName name) tycon ty tag | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ] in mk_data_con arg_stricts arg_tys field_labels