X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=d7118e1f816bc84c29ad472aae75a97531cdf1e0;hp=51d6f4b6032601e357acd038cc46768baef87252;hb=215ce9f15215399ce30ae55c9521087847d78646;hpb=e79c9ce01d0ce4412bd4bcd99c8c728a6a2ec569 diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 51d6f4b..d7118e1 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -12,7 +12,9 @@ -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details -module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, tcInferRho, tcInferRhoNC, tcSyntaxOp, addExprErrCtxt ) where +module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, + tcInferRho, tcInferRhoNC, tcSyntaxOp, + addExprErrCtxt ) where #include "HsVersions.h" @@ -245,41 +247,73 @@ tcExpr in_expr@(OpApp arg1 lop@(L loc op) fix arg2) res_ty -- but it's less work and kind of useful. tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty - = do dflags <- getDOpts - if dopt Opt_PostfixOperators dflags - then do (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty - return (SectionL arg1' (L loc op')) - else do (co_fn, (op', arg1')) - <- subFunTys doc 1 res_ty Nothing - $ \ [arg2_ty'] res_ty' -> - tcApp op 2 (tc_args arg2_ty') res_ty' - return (mkHsWrap co_fn (SectionL arg1' (L loc op'))) + = do { dflags <- getDOpts + ; if dopt Opt_PostfixOperators dflags + then do { (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty + ; return (SectionL arg1' (L loc op')) } + else do + { (co_fn, expr') + <- subFunTys doc 1 res_ty Nothing $ \ [arg2_ty'] res_ty' -> + do { (op', (arg1', co_arg2)) <- tcApp op 2 (tc_args arg2_ty') res_ty' + ; let coi = mkFunTyCoI arg2_ty' co_arg2 res_ty' IdCo + ; return (mkHsWrapCoI coi (SectionL arg1' (L loc op'))) } + ; return (mkHsWrap co_fn expr') } } where doc = ptext (sLit "The section") <+> quotes (ppr in_expr) <+> ptext (sLit "takes one argument") tc_args arg2_ty' qtvs qtys [arg1_ty, arg2_ty] - = do { boxyUnify arg2_ty' (substTyWith qtvs qtys arg2_ty) - ; arg1' <- tcArg lop 2 arg1 qtvs qtys arg1_ty - ; qtys' <- mapM refineBox qtys -- c.f. tcArgs - ; return (qtys', arg1') } + = do { co_arg2 <- boxyUnify (substTyWith qtvs qtys arg2_ty) arg2_ty' + ; arg1' <- tcArg lop 1 arg1 qtvs qtys arg1_ty + ; qtys' <- mapM refineBox qtys -- c.f. tcArgs + ; return (qtys', (arg1', co_arg2)) } tc_args _ _ _ _ = panic "tcExpr SectionL" -- Right sections, equivalent to \ x -> x `op` expr, or -- \ x -> op x expr tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty - = do { (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty Nothing $ \ [arg1_ty'] res_ty' -> - tcApp op 2 (tc_args arg1_ty') res_ty' - ; return (mkHsWrap co_fn (SectionR (L loc op') arg2')) } + = do { (co_fn, expr') + <- subFunTys doc 1 res_ty Nothing $ \ [arg1_ty'] res_ty' -> + do { (op', (co_arg1, arg2')) <- tcApp op 2 (tc_args arg1_ty') res_ty' + ; let coi = mkFunTyCoI arg1_ty' co_arg1 res_ty' IdCo + ; return (mkHsWrapCoI coi $ SectionR (L loc op') arg2') } + ; return (mkHsWrap co_fn expr') } where doc = ptext (sLit "The section") <+> quotes (ppr in_expr) <+> ptext (sLit "takes one argument") tc_args arg1_ty' qtvs qtys [arg1_ty, arg2_ty] - = do { boxyUnify arg1_ty' (substTyWith qtvs qtys arg1_ty) - ; arg2' <- tcArg lop 2 arg2 qtvs qtys arg2_ty - ; qtys' <- mapM refineBox qtys -- c.f. tcArgs - ; return (qtys', arg2') } + = do { co_arg1 <- boxyUnify (substTyWith qtvs qtys arg1_ty) arg1_ty' + ; arg2' <- tcArg lop 2 arg2 qtvs qtys arg2_ty + ; qtys' <- mapM refineBox qtys -- c.f. tcArgs + ; return (qtys', (co_arg1, arg2')) } tc_args arg1_ty' _ _ _ = panic "tcExpr SectionR" + +-- For tuples, take care to preserve rigidity +-- E.g. case (x,y) of .... +-- The scrutinee should have a rigid type if x,y do +-- The general scheme is the same as in tcIdApp +tcExpr in_expr@(ExplicitTuple tup_args boxity) res_ty + = do { let kind = case boxity of { Boxed -> liftedTypeKind + ; Unboxed -> argTypeKind } + arity = length tup_args + tup_tc = tupleTyCon boxity arity + mk_tup_res_ty arg_tys + = mkFunTys [ty | (ty, Missing _) <- arg_tys `zip` tup_args] + (mkTyConApp tup_tc arg_tys) + + ; checkWiredInTyCon tup_tc -- Ensure instances are available + ; tvs <- newBoxyTyVars (replicate arity kind) + ; let arg_tys1 = map mkTyVarTy tvs + ; arg_tys2 <- preSubType tvs (mkVarSet tvs) (mk_tup_res_ty arg_tys1) res_ty + + ; let go (Missing _, arg_ty) = return (Missing arg_ty) + go (Present expr, arg_ty) = do { expr' <- tcPolyExpr expr arg_ty + ; return (Present expr') } + ; tup_args' <- mapM go (tup_args `zip` arg_tys2) + + ; arg_tys3 <- mapM refineBox arg_tys2 + ; co_fn <- tcSubExp TupleOrigin (mk_tup_res_ty arg_tys3) res_ty + ; return (mkHsWrap co_fn (ExplicitTuple tup_args' boxity)) } \end{code} \begin{code} @@ -344,23 +378,6 @@ tcExpr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty where tc_elt elt_ty expr = tcPolyExpr expr elt_ty --- For tuples, take care to preserve rigidity --- E.g. case (x,y) of .... --- The scrutinee should have a rigid type if x,y do --- The general scheme is the same as in tcIdApp -tcExpr (ExplicitTuple exprs boxity) res_ty - = do { let kind = case boxity of { Boxed -> liftedTypeKind - ; Unboxed -> argTypeKind } - ; tvs <- newBoxyTyVars [kind | e <- exprs] - ; let tup_tc = tupleTyCon boxity (length exprs) - tup_res_ty = mkTyConApp tup_tc (mkTyVarTys tvs) - ; checkWiredInTyCon tup_tc -- Ensure instances are available - ; arg_tys <- preSubType tvs (mkVarSet tvs) tup_res_ty res_ty - ; exprs' <- tcPolyExprs exprs arg_tys - ; arg_tys' <- mapM refineBox arg_tys - ; co_fn <- tcSubExp TupleOrigin (mkTyConApp tup_tc arg_tys') res_ty - ; return (mkHsWrap co_fn (ExplicitTuple exprs' boxity)) } - tcExpr (HsProc pat cmd) res_ty = do { (pat', cmd', coi) <- tcProc pat cmd res_ty ; return $ mkHsWrapCoI coi (HsProc pat' cmd') } @@ -408,16 +425,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 +446,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 +474,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 +523,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 +556,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 +564,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 +578,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 +617,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} %************************************************************************ @@ -809,12 +850,12 @@ tcId :: InstOrigin -> BoxyRhoType -- Result type -> TcM (HsExpr TcId) tcId orig fun_name res_ty - = do { traceTc (text "tcId" <+> ppr fun_name <+> ppr res_ty) - ; (fun, fun_ty) <- lookupFun orig fun_name - + = do { (fun, fun_ty) <- lookupFun orig fun_name + ; traceTc (text "tcId" <+> ppr fun_name <+> (ppr fun_ty $$ ppr res_ty)) + -- Split up the function type ; let (tv_theta_prs, fun_tau) = tcMultiSplitSigmaTy fun_ty - qtvs = concatMap fst tv_theta_prs -- Quantified tyvars + qtvs = concatMap fst tv_theta_prs -- Quantified tyvars tau_qtvs = exactTyVarsOfType fun_tau -- Mentioned in the tau part ; qtv_tys <- preSubType qtvs tau_qtvs fun_tau res_ty @@ -822,6 +863,8 @@ tcId orig fun_name res_ty ; let res_subst = zipTopTvSubst qtvs qtv_tys fun_tau' = substTy res_subst fun_tau + ; traceTc (text "tcId2" <+> ppr fun_name <+> (ppr qtvs $$ ppr qtv_tys)) + ; co_fn <- tcSubExp orig fun_tau' res_ty -- And pack up the results @@ -856,9 +899,10 @@ tcId orig fun_name res_ty tcSyntaxOp :: InstOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId) -- Typecheck a syntax operator, checking that it has the specified type -- The operator is always a variable at this stage (i.e. renamer output) +-- This version assumes ty is a monotype tcSyntaxOp orig (HsVar op) ty = tcId orig op ty -tcSyntaxOp orig other ty = pprPanic "tcSyntaxOp" (ppr other) - +tcSyntaxOp orig other ty = pprPanic "tcSyntaxOp" (ppr other) + --------------------------- instFun :: InstOrigin -> HsExpr TcId @@ -972,7 +1016,7 @@ tcArgs :: LHsExpr Name -- The function (for error messages) type ArgChecker results = [TyVar] -> [TcSigmaType] -- Current instantiation -> [TcSigmaType] -- Expected arg types (**before** applying the instantiation) - -> TcM ([TcSigmaType], results) -- Resulting instaniation and args + -> TcM ([TcSigmaType], results) -- Resulting instantiation and args tcArgs fun args qtvs qtys arg_tys = go 1 qtys args arg_tys @@ -1069,6 +1113,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) @@ -1082,22 +1129,31 @@ lookupFun orig id_name #ifndef GHCI /* GHCI and TH is off */ -------------------------------------- --- thLocalId : Check for cross-stage lifting -thLocalId orig id id_ty th_bind_lvl +thLocalId :: InstOrigin -> Id -> TcType -> ThLevel -> TcM () +-- Check for cross-stage lifting +thLocalId orig id id_ty bind_lvl = return () #else /* GHCI and TH is on */ -thLocalId orig id id_ty th_bind_lvl +thLocalId orig id id_ty bind_lvl = do { use_stage <- getStage -- TH case - ; case use_stage of - Brack use_lvl ps_var lie_var | use_lvl > th_bind_lvl - -> thBrackId orig id ps_var lie_var - other -> do { checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage - ; return id } - } + ; let use_lvl = thLevel use_stage + ; checkWellStaged (quotes (ppr id)) bind_lvl use_lvl + ; traceTc (text "thLocalId" <+> ppr id <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl) + ; when (use_lvl > bind_lvl) $ + checkCrossStageLifting orig id id_ty bind_lvl use_stage } -------------------------------------- -thBrackId orig id ps_var lie_var +checkCrossStageLifting :: InstOrigin -> Id -> TcType -> ThLevel -> ThStage -> TcM () +-- We are inside brackets, and (use_lvl > bind_lvl) +-- Now we must check whether there's a cross-stage lift to do +-- Examples \x -> [| x |] +-- [| map |] + +checkCrossStageLifting _ _ _ _ Comp = return () +checkCrossStageLifting _ _ _ _ Splice = return () + +checkCrossStageLifting orig id id_ty bind_lvl (Brack _ ps_var lie_var) | thTopLevelId id = -- Top-level identifiers in this module, -- (which have External Names) @@ -1109,9 +1165,10 @@ thBrackId orig id ps_var lie_var -- But we do need to put f into the keep-alive -- set, because after desugaring the code will -- only mention f's *name*, not f itself. - do { keepAliveTc id; return id } + keepAliveTc id - | otherwise + | otherwise -- bind_lvl = outerLevel presumably, + -- but the Id is not bound at top level = -- Nested identifiers, such as 'x' in -- E.g. \x -> [| h x |] -- We must behave as if the reference to x was @@ -1121,8 +1178,7 @@ thBrackId orig id ps_var lie_var -- If 'x' occurs many times we may get many identical -- bindings of the same splice proxy, but that doesn't -- matter, although it's a mite untidy. - do { let id_ty = idType id - ; checkTc (isTauTy id_ty) (polySpliceErr id) + do { checkTc (isTauTy id_ty) (polySpliceErr id) -- If x is polymorphic, its occurrence sites might -- have different instantiations, so we can't use plain -- 'x' as the splice proxy name. I don't know how to @@ -1135,18 +1191,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 () } #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. + %************************************************************************ %* * @@ -1203,7 +1280,7 @@ checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM () checkMissingFields data_con rbinds | null field_labels -- Not declared as a record; -- But C{} is still valid if no strict fields - = if any isMarkedStrict field_strs then + = if any isBanged field_strs then -- Illegal if any arg is strict addErrTc (missingStrictFields data_con []) else @@ -1220,12 +1297,12 @@ checkMissingFields data_con rbinds where missing_s_fields = [ fl | (fl, str) <- field_info, - isMarkedStrict str, + isBanged str, not (fl `elem` field_names_used) ] missing_ns_fields = [ fl | (fl, str) <- field_info, - not (isMarkedStrict str), + not (isBanged str), not (fl `elem` field_names_used) ]