X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=93d3fe93caa49942e9c8f44f064828d949db97e1;hp=51d6f4b6032601e357acd038cc46768baef87252;hb=4a343629ebe5be2c5b27e84c031e38abd81122fa;hpb=e79c9ce01d0ce4412bd4bcd99c8c728a6a2ec569 diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 51d6f4b..93d3fe9 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -408,16 +408,20 @@ Note [Type of a record update] The main complication with RecordUpd is that we need to explicitly handle the *non-updated* fields. Consider: - data T a b = MkT1 { fa :: a, fb :: b } - | MkT2 { fa :: a, fc :: Int -> Int } - | MkT3 { fd :: a } + data T a b c = MkT1 { fa :: a, fb :: (b,c) } + | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c } + | MkT3 { fd :: a } - upd :: T a b -> c -> T a c + upd :: T a b c -> (b',c) -> T a b' c upd t x = t { fb = x} -The type signature on upd is correct (i.e. the result should not be (T a b)) -because upd should be equivalent to: +The result type should be (T a b' c) +not (T a b c), because 'b' *is not* mentioned in a non-updated field +not (T a b' c'), becuase 'c' *is* mentioned in a non-updated field +NB that it's not good enough to look at just one constructor; we must +look at them all; cf Trac #3219 +After all, upd should be equivalent to: upd t x = case t of MkT1 p q -> MkT1 p x MkT2 a b -> MkT2 p b @@ -425,9 +429,11 @@ because upd should be equivalent to: So we need to give a completely fresh type to the result record, and then constrain it by the fields that are *not* updated ("p" above). +We call these the "fixed" type variables, and compute them in getFixedTyVars. Note that because MkT3 doesn't contain all the fields being updated, -its RHS is simply an error, so it doesn't impose any type constraints +its RHS is simply an error, so it doesn't impose any type constraints. +Hence the use of 'relevant_cont'. Note [Implict type sharing] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -451,12 +457,22 @@ field isn't part of the existential. For example, this should be ok. data T a where { MkT { f1::a, f2::b->b } :: T a } f :: T a -> b -> T b f t b = t { f1=b } + The criterion we use is this: The types of the updated fields mention only the universally-quantified type variables of the data constructor +NB: this is not (quite) the same as being a "naughty" record selector +(See Note [Naughty record selectors]) in TcTyClsDecls), at least +in the case of GADTs. Consider + data T a where { MkT :: { f :: a } :: T [a] } +Then f is not "naughty" because it has a well-typed record selector. +But we don't allow updates for 'f'. (One could consider trying to +allow this, but it makes my head hurt. Badly. And no one has asked +for it.) + In principle one could go further, and allow g :: T a -> T a g t = t { f2 = \x -> x } @@ -490,11 +506,10 @@ In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys): \begin{code} tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty - = do { + = ASSERT( notNull upd_fld_names ) + do { -- STEP 0 -- Check that the field names are really field names - let upd_fld_names = hsRecFields rbinds - ; MASSERT( notNull upd_fld_names ) ; sel_ids <- mapM tcLookupField upd_fld_names -- The renamer has already checked that -- selectors are all in scope @@ -524,7 +539,7 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty con1_flds = dataConFieldLabels con1 con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs) - -- STEP 2 + -- Step 2 -- Check that at least one constructor has all the named fields -- i.e. has an empty set of bad fields returned by badFields ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds) @@ -532,11 +547,11 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty -- STEP 3 Note [Criteria for update] -- Check that each updated field is polymorphic; that is, its type -- mentions only the universally-quantified variables of the data con - ; let flds_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys - (upd_flds_w_tys, fixed_flds_w_tys) = partition is_updated flds_w_tys + ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys + (upd_flds1_w_tys, fixed_flds1_w_tys) = partition is_updated flds1_w_tys is_updated (fld,ty) = fld `elem` upd_fld_names - bad_upd_flds = filter bad_fld upd_flds_w_tys + bad_upd_flds = filter bad_fld upd_flds1_w_tys con1_tv_set = mkVarSet con1_tvs bad_fld (fld, ty) = fld `elem` upd_fld_names && not (tyVarsOfType ty `subVarSet` con1_tv_set) @@ -546,14 +561,14 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty -- Figure out types for the scrutinee and result -- Both are of form (T a b c), with fresh type variables, but with -- common variables where the scrutinee and result must have the same type - -- These are variables that appear anywhere *except* in the updated fields - ; let common_tvs = exactTyVarsOfTypes (map snd fixed_flds_w_tys) - `unionVarSet` constrainedTyVars con1_tvs relevant_cons - is_common_tv tv = tv `elemVarSet` common_tvs - + -- These are variables that appear in *any* arg of *any* of the + -- relevant constructors *except* in the updated fields + -- + ; let fixed_tvs = getFixedTyVars con1_tvs relevant_cons + is_fixed_tv tv = tv `elemVarSet` fixed_tvs mk_inst_ty tv result_inst_ty - | is_common_tv tv = return result_inst_ty -- Same as result type - | otherwise = newFlexiTyVarTy (tyVarKind tv) -- Fresh type, of correct kind + | is_fixed_tv tv = return result_inst_ty -- Same as result type + | otherwise = newFlexiTyVarTy (tyVarKind tv) -- Fresh type, of correct kind ; (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tvs ; scrut_inst_tys <- zipWithM mk_inst_ty con1_tvs result_inst_tys @@ -585,17 +600,26 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty ; return (mkHsWrap co_fn (RecordUpd (mkLHsWrap scrut_co record_expr') rbinds' relevant_cons scrut_inst_tys result_inst_tys)) } where - constrainedTyVars :: [TyVar] -> [DataCon] -> TyVarSet - -- Universally-quantified tyvars that appear in any of the - -- *implicit* arguments to the constructor + upd_fld_names = hsRecFields rbinds + + getFixedTyVars :: [TyVar] -> [DataCon] -> TyVarSet -- These tyvars must not change across the updates - -- See Note [Implict type sharing] - constrainedTyVars tvs1 cons + getFixedTyVars tvs1 cons = mkVarSet [tv1 | con <- cons - , let (tvs, theta, _, _) = dataConSig con - bad_tvs = tyVarsOfTheta theta + , let (tvs, theta, arg_tys, _) = dataConSig con + flds = dataConFieldLabels con + fixed_tvs = exactTyVarsOfTypes fixed_tys + -- fixed_tys: See Note [Type of a record update] + `unionVarSet` tyVarsOfTheta theta + -- Universally-quantified tyvars that + -- appear in any of the *implicit* + -- arguments to the constructor are fixed + -- See Note [Implict type sharing] + + fixed_tys = [ty | (fld,ty) <- zip flds arg_tys + , not (fld `elem` upd_fld_names)] , (tv1,tv) <- tvs1 `zip` tvs -- Discards existentials in tvs - , tv `elemVarSet` bad_tvs ] + , tv `elemVarSet` fixed_tvs ] \end{code} %************************************************************************ @@ -1069,6 +1093,9 @@ lookupFun orig id_name -- nor does it need the 'lifting' treatment ATcId { tct_id = id, tct_type = ty, tct_co = mb_co, tct_level = lvl } + | isNaughtyRecordSelector id -> failWithTc (naughtyRecordSel id) + -- Note [Local record selectors] + | otherwise -> do { thLocalId orig id ty lvl ; case mb_co of Unrefineable -> return (HsVar id, ty) @@ -1135,18 +1162,39 @@ thBrackId orig id ps_var lie_var -- so we zap it to a LiftedTypeKind monotype -- C.f. the call in TcPat.newLitInst - ; setLIEVar lie_var $ do - { lift <- newMethodFromName orig id_ty' DsMeta.liftName - -- Put the 'lift' constraint into the right LIE + ; lift <- if isStringTy id_ty' then + tcLookupId DsMeta.liftStringName + -- See Note [Lifting strings] + else + setLIEVar lie_var $ do -- Put the 'lift' constraint into the right LIE + newMethodFromName orig id_ty' DsMeta.liftName -- Update the pending splices ; ps <- readMutVar ps_var ; writeMutVar ps_var ((idName id, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps) - ; return id } } + ; return id } #endif /* GHCI */ \end{code} +Note [Lifting strings] +~~~~~~~~~~~~~~~~~~~~~~ +If we see $(... [| s |] ...) where s::String, we don't want to +generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc. +So this conditional short-circuits the lifting mechanism to generate +(liftString "xy") in that case. I didn't want to use overlapping instances +for the Lift class in TH.Syntax, because that can lead to overlapping-instance +errors in a polymorphic situation. + +If this check fails (which isn't impossible) we get another chance; see +Note [Converting strings] in Convert.lhs + +Local record selectors +~~~~~~~~~~~~~~~~~~~~~~ +Record selectors for TyCons in this module are ordinary local bindings, +which show up as ATcIds rather than AGlobals. So we need to check for +naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds. + %************************************************************************ %* *