-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
-module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcInferRho, tcSyntaxOp ) where
+module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, tcInferRho, tcInferRhoNC, tcSyntaxOp, addExprErrCtxt ) where
#include "HsVersions.h"
import Outputable
import FastString
+import Data.List( partition )
import Control.Monad
\end{code}
-- to do so himself.
tcPolyExpr expr res_ty
- = addErrCtxt (exprCtxt (unLoc expr)) $
+ = addExprErrCtxt expr $
(do {traceTc (text "tcPolyExpr") ; tcPolyExprNC expr res_ty })
tcPolyExprNC expr res_ty
| isSigmaTy res_ty
= do { traceTc (text "tcPolyExprNC" <+> ppr res_ty)
- ; (gen_fn, expr') <- tcGen res_ty emptyVarSet (\_ -> tcPolyExprNC expr)
+ ; (gen_fn, expr') <- tcGen res_ty emptyVarSet Nothing $ \ _ res_ty ->
+ tcPolyExprNC expr res_ty
-- Note the recursive call to tcPolyExpr, because the
-- type may have multiple layers of for-alls
-- E.g. forall a. Eq a => forall b. Ord b => ....
; return (mkLHsWrap gen_fn expr') }
| otherwise
- = tcMonoExpr expr res_ty
+ = tcMonoExprNC expr res_ty
---------------
tcPolyExprs :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId]
tcPolyExprs exprs tys = pprPanic "tcPolyExprs" (ppr exprs $$ ppr tys)
---------------
-tcMonoExpr :: LHsExpr Name -- Expression to type check
- -> BoxyRhoType -- Expected type (could be a type variable)
- -- Definitely no foralls at the top
- -- Can contain boxes, which will be filled in
- -> TcM (LHsExpr TcId)
-
-tcMonoExpr (L loc expr) res_ty
+tcMonoExpr, tcMonoExprNC
+ :: LHsExpr Name -- Expression to type check
+ -> BoxyRhoType -- Expected type (could be a type variable)
+ -- Definitely no foralls at the top
+ -- Can contain boxes, which will be filled in
+ -> TcM (LHsExpr TcId)
+
+tcMonoExpr expr res_ty
+ = addErrCtxt (exprCtxt expr) $
+ tcMonoExprNC expr res_ty
+
+tcMonoExprNC (L loc expr) res_ty
= ASSERT( not (isSigmaTy res_ty) )
setSrcSpan loc $
do { expr' <- tcExpr expr res_ty
; return (L loc expr') }
---------------
-tcInferRho :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
-tcInferRho expr = tcInfer (tcMonoExpr expr)
+tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
+tcInferRho expr = tcInfer (tcMonoExpr expr)
+tcInferRhoNC expr = tcInfer (tcMonoExprNC expr)
\end{code}
\begin{code}
tcExpr :: HsExpr Name -> BoxyRhoType -> TcM (HsExpr TcId)
+tcExpr e res_ty | debugIsOn && isSigmaTy res_ty -- Sanity check
+ = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e)
+
tcExpr (HsVar name) res_ty = tcId (OccurrenceOf name) name res_ty
tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit
; return $ mkHsWrapCoI coi (HsLit lit)
}
-tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
+tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty
; return (HsPar expr') }
tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
= do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
-- Remember to extend the lexical type-variable environment
- ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (\ skol_tvs res_ty ->
+ ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (Just ExprSigCtxt) $ \ skol_tvs res_ty ->
tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
- tcPolyExprNC expr res_ty)
+ -- See Note [More instantiated than scoped] in TcBinds
+ tcMonoExprNC expr res_ty
; co_fn <- tcSubExp ExprSigOrigin sig_tc_ty res_ty
; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) }
-- \ x -> e op x,
-- or
-- \ x -> op e x,
--- or just
+-- or, if PostfixOperators is enabled, just
-- op e
--
--- We treat it as similar to the latter, so we don't
+-- With PostfixOperators we don't
-- actually require the function to take two arguments
-- at all. For example, (x `not`) means (not x);
--- you get postfix operators! Not really Haskell 98
--- I suppose, but it's less work and kind of useful.
+-- you get postfix operators! Not Haskell 98,
+-- but it's less work and kind of useful.
tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty
- = do { (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty
- ; return (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, (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')))
+ 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') }
+ 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 $ \ [arg1_ty'] 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')) }
where
- doc = ptext SLIT("The section") <+> quotes (ppr in_expr)
- <+> ptext SLIT("takes one argument")
+ 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
--
-- But now, in the GADT world, we need to typecheck the scrutinee
-- first, to get type info that may be refined in the case alternatives
- (scrut', scrut_ty) <- addErrCtxt (caseScrutCtxt scrut)
- (tcInferRho scrut)
+ (scrut', scrut_ty) <- tcInferRho scrut
; traceTc (text "HsCase" <+> ppr scrut_ty)
; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
mc_body = tcBody }
tcExpr (HsIf pred b1 b2) res_ty
- = do { pred' <- addErrCtxt (predCtxt pred) $
- tcMonoExpr pred boolTy
+ = do { pred' <- tcMonoExpr pred boolTy
; b1' <- tcMonoExpr b1 res_ty
; b2' <- tcMonoExpr b2 res_ty
; return (HsIf pred' b1' b2') }
tcExpr (HsDo do_or_lc stmts body _) res_ty
= tcDoStmts do_or_lc stmts body res_ty
-tcExpr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list
+tcExpr in_expr@(ExplicitList _ exprs) res_ty
= do { (elt_ty, coi) <- boxySplitListTy res_ty
; exprs' <- mapM (tc_elt elt_ty) exprs
+ ; when (null exprs) (zapToMonotype elt_ty >> return ())
+ -- If there are no expressions in the comprehension
+ -- we must still fill in the box
+ --
+ -- The GHC front end never generates an empty ExplicitList
+ -- (instead it generates the [] data constructor) but
+ -- Template Haskell might. We could fix the bit of
+ -- TH that generates ExplicitList, but it seems less
+ -- fragile to just handle the case here.
; return $ mkHsWrapCoI coi (ExplicitList elt_ty exprs') }
where
tc_elt elt_ty expr = tcPolyExpr expr elt_ty
-- 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 { tvs <- newBoxyTyVars [argTypeKind | e <- exprs]
+ = 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
; return $ mkHsWrapCoI coi (HsProc pat' cmd') }
tcExpr e@(HsArrApp _ _ _ _ _) _
- = failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e),
- ptext SLIT("was found where an expression was expected")])
+ = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e),
+ ptext (sLit "was found where an expression was expected")])
tcExpr e@(HsArrForm _ _ _) _
- = failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e),
- ptext SLIT("was found where an expression was expected")])
+ = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e),
+ ptext (sLit "was found where an expression was expected")])
\end{code}
%************************************************************************
; (con_expr, rbinds') <- tcIdApp con_name arity check_fields res_ty
; return (RecordCon (L loc (dataConWrapId data_con)) con_expr rbinds') }
+\end{code}
--- 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 }
---
--- upd :: T a b -> c -> T a 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:
---
--- upd t x = case t of
--- MkT1 p q -> MkT1 p x
--- MkT2 a b -> MkT2 p b
--- MkT3 d -> error ...
---
--- 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).
---
--- 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
---
--- All this is done in STEP 4 below.
---
--- Note about GADTs
--- ~~~~~~~~~~~~~~~~
--- For record update we require that every constructor involved in the
--- update (i.e. that has all the specified fields) is "vanilla". I
--- don't know how to do the update otherwise.
-
+Note [Type of a record update]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The main complication with RecordUpd is that we need to explicitly
+handle the *non-updated* fields. Consider:
-tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty = do
+ data T a b = MkT1 { fa :: a, fb :: b }
+ | MkT2 { fa :: a, fc :: Int -> Int }
+ | MkT3 { fd :: a }
+
+ upd :: T a b -> c -> T a 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:
+
+ upd t x = case t of
+ MkT1 p q -> MkT1 p x
+ MkT2 a b -> MkT2 p b
+ MkT3 d -> error ...
+
+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).
+
+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
+
+Note [Implict type sharing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We also take into account any "implicit" non-update fields. For example
+ data T a b where { MkT { f::a } :: T a a; ... }
+So the "real" type of MkT is: forall ab. (a~b) => a -> T a b
+
+Then consider
+ upd t x = t { f=x }
+We infer the type
+ upd :: T a b -> a -> T a b
+ upd (t::T a b) (x::a)
+ = case t of { MkT (co:a~b) (_:a) -> MkT co x }
+We can't give it the more general type
+ upd :: T a b -> c -> T c b
+
+Note [Criteria for update]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to allow update for existentials etc, provided the updated
+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
+
+In principle one could go further, and allow
+ g :: T a -> T a
+ g t = t { f2 = \x -> x }
+because the expression is polymorphic...but that seems a bridge too far.
+
+Note [Data family example]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+ data instance T (a,b) = MkT { x::a, y::b }
+ --->
+ data :TP a b = MkT { a::a, y::b }
+ coTP a b :: T (a,b) ~ :TP a b
+
+Suppose r :: T (t1,t2), e :: t3
+Then r { x=e } :: T (t3,t1)
+ --->
+ case r |> co1 of
+ MkT x y -> MkT e y |> co2
+ where co1 :: T (t1,t2) ~ :TP t1 t2
+ co2 :: :TP t3 t2 ~ T (t3,t2)
+The wrapping with co2 is done by the constructor wrapper for MkT
+
+Outgoing invariants
+~~~~~~~~~~~~~~~~~~~
+In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):
+
+ * cons are the data constructors to be updated
+
+ * in_inst_tys, out_inst_tys have same length, and instantiate the
+ *representation* tycon of the data cons. In Note [Data
+ family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]
+
+\begin{code}
+tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty
+ = do {
-- STEP 0
-- Check that the field names are really field names
- let
- field_names = hsRecFields rbinds
-
- MASSERT( notNull field_names )
- sel_ids <- mapM tcLookupField field_names
- -- The renamer has already checked that they
- -- are all in scope
- let
- bad_guys = [ setSrcSpan loc $ addErrTc (notSelector field_name)
- | (fld, sel_id) <- rec_flds rbinds `zip` sel_ids,
- not (isRecordSelector sel_id), -- Excludes class ops
- let L loc field_name = hsRecFieldId fld
- ]
-
- unless (null bad_guys) (sequence bad_guys >> failM)
+ 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
+ ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
+ | (fld, sel_id) <- rec_flds rbinds `zip` sel_ids,
+ not (isRecordSelector sel_id), -- Excludes class ops
+ let L loc fld_name = hsRecFieldId fld ]
+ ; unless (null bad_guys) (sequence bad_guys >> failM)
-- STEP 1
-- Figure out the tycon and data cons from the first field name
- let
- -- It's OK to use the non-tc splitters here (for a selector)
- sel_id : _ = sel_ids
- (tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if
- data_cons = tyConDataCons tycon -- it's not a field label
- -- NB: for a data type family, the tycon is the instance tycon
-
- relevant_cons = filter is_relevant data_cons
- is_relevant con = all (`elem` dataConFieldLabels con) field_names
-
+ ; let -- It's OK to use the non-tc splitters here (for a selector)
+ sel_id : _ = sel_ids
+ (tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if
+ data_cons = tyConDataCons tycon -- it's not a field label
+ -- NB: for a data type family, the tycon is the instance tycon
+
+ relevant_cons = filter is_relevant data_cons
+ is_relevant con = all (`elem` dataConFieldLabels con) upd_fld_names
+ -- A constructor is only relevant to this process if
+ -- it contains *all* the fields that are being updated
+ -- Other ones will cause a runtime error if they occur
+
+ -- Take apart a representative constructor
+ con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
+ (con1_tvs, _, _, _, _, con1_arg_tys, _) = dataConFullSig con1
+ con1_flds = dataConFieldLabels con1
+ con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs)
+
-- 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)
-
- -- Check that all relevant data cons are vanilla. Doing record updates on
- -- GADTs and/or existentials is more than my tiny brain can cope with today
- checkTc (all isVanillaDataCon relevant_cons)
- (nonVanillaUpd tycon)
-
- -- STEP 4
- -- Use the un-updated fields to find a vector of booleans saying
- -- which type arguments must be the same in updatee and result.
- --
- -- WARNING: this code assumes that all data_cons in a common tycon
- -- have FieldLabels abstracted over the same tyvars.
- let
- -- A constructor is only relevant to this process if
- -- it contains *all* the fields that are being updated
- con1 = ASSERT( not (null relevant_cons) ) head relevant_cons -- A representative constructor
- (con1_tyvars, theta, con1_arg_tys, con1_res_ty) = dataConSig con1
- con1_flds = dataConFieldLabels con1
- common_tyvars = exactTyVarsOfTypes [ty | (fld,ty) <- con1_flds `zip` con1_arg_tys
- , not (fld `elem` field_names) ]
-
- is_common_tv tv = tv `elemVarSet` common_tyvars
-
- 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
-
- MASSERT( null theta ) -- Vanilla datacon
- (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tyvars
- scrut_inst_tys <- zipWithM mk_inst_ty con1_tyvars result_inst_tys
-
- -- STEP 3: Typecheck the update bindings.
- -- Do this after checking for bad fields in case
- -- there's a field that doesn't match the constructor.
- let
- result_ty = substTy result_inst_env con1_res_ty
- con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys
- origin = RecordUpdOrigin
-
- co_fn <- tcSubExp origin result_ty res_ty
- rbinds' <- tcRecordBinds con1 con1_arg_tys' rbinds
-
- -- STEP 5: Typecheck the expression to be updated
- let
- scrut_inst_env = zipTopTvSubst con1_tyvars scrut_inst_tys
- scrut_ty = substTy scrut_inst_env con1_res_ty
- -- This is one place where the isVanilla check is important
- -- So that inst_tys matches the con1_tyvars
-
- record_expr' <- tcMonoExpr record_expr scrut_ty
-
- -- STEP 6: Figure out the LIE we need.
- -- We have to generate some dictionaries for the data type context,
- -- since we are going to do pattern matching over the data cons.
- --
- -- What dictionaries do we need? The dataConStupidTheta tells us.
- let
- theta' = substTheta scrut_inst_env (dataConStupidTheta con1)
-
- instStupidTheta origin theta'
+ ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds)
+
+ -- 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
+ is_updated (fld,ty) = fld `elem` upd_fld_names
+
+ bad_upd_flds = filter bad_fld upd_flds_w_tys
+ con1_tv_set = mkVarSet con1_tvs
+ bad_fld (fld, ty) = fld `elem` upd_fld_names &&
+ not (tyVarsOfType ty `subVarSet` con1_tv_set)
+ ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds)
+
+ -- STEP 4 Note [Type of a record update]
+ -- 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
+
+ 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
+
+ ; (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tvs
+ ; scrut_inst_tys <- zipWithM mk_inst_ty con1_tvs result_inst_tys
+
+ ; let result_ty = substTy result_inst_env con1_res_ty
+ con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys
+ scrut_subst = zipTopTvSubst con1_tvs scrut_inst_tys
+ scrut_ty = substTy scrut_subst con1_res_ty
+
+ -- STEP 5
+ -- Typecheck the thing to be updated, and the bindings
+ ; record_expr' <- tcMonoExpr record_expr scrut_ty
+ ; rbinds' <- tcRecordBinds con1 con1_arg_tys' rbinds
+
+ ; let origin = RecordUpdOrigin
+ ; co_fn <- tcSubExp origin result_ty res_ty
+
+ -- STEP 6: Deal with the stupid theta
+ ; let theta' = substTheta scrut_subst (dataConStupidTheta con1)
+ ; instStupidTheta origin theta'
-- Step 7: make a cast for the scrutinee, in the case that it's from a type family
- let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon
- = WpCo $ mkTyConApp co_con scrut_inst_tys
- | otherwise
- = idHsWrapper
+ ; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon
+ = WpCast $ mkTyConApp co_con scrut_inst_tys
+ | otherwise
+ = idHsWrapper
-- Phew!
- return (mkHsWrap co_fn (RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
- relevant_cons scrut_inst_tys result_inst_tys))
+ ; 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
+ -- These tyvars must not change across the updates
+ -- See Note [Implict type sharing]
+ constrainedTyVars tvs1 cons
+ = mkVarSet [tv1 | con <- cons
+ , let (tvs, theta, _, _) = dataConSig con
+ bad_tvs = tyVarsOfTheta theta
+ , (tv1,tv) <- tvs1 `zip` tvs -- Discards existentials in tvs
+ , tv `elemVarSet` bad_tvs ]
\end{code}
-
%************************************************************************
%* *
Arithmetic sequences e.g. [a,b..]
; doStupidChecks fun ty_theta_prs'
-- Now do normal instantiation
- ; result <- go True fun ty_theta_prs'
+ ; method_sharing <- doptM Opt_MethodSharing
+ ; result <- go method_sharing True fun ty_theta_prs'
; traceTc (text "instFun result" <+> ppr result)
; return result
}
subst_pr (tvs, theta)
= (substTyVars subst tvs, substTheta subst theta)
- go _ fun [] = do {traceTc (text "go _ fun [] returns" <+> ppr fun) ; return fun }
+ go _ _ fun [] = do {traceTc (text "go _ _ fun [] returns" <+> ppr fun) ; return fun }
- go True (HsVar fun_id) ((tys,theta) : prs)
- | want_method_inst theta
+ go method_sharing True (HsVar fun_id) ((tys,theta) : prs)
+ | want_method_inst method_sharing theta
= do { traceTc (text "go (HsVar fun_id) ((tys,theta) : prs) | want_method_inst theta")
; meth_id <- newMethodWithGivenTy orig fun_id tys
- ; go False (HsVar meth_id) prs }
+ ; go method_sharing False (HsVar meth_id) prs }
-- Go round with 'False' to prevent further use
-- of newMethod: see Note [Multiple instantiation]
- go _ fun ((tys, theta) : prs)
+ go method_sharing _ fun ((tys, theta) : prs)
= do { co_fn <- instCall orig tys theta
; traceTc (text "go yields co_fn" <+> ppr co_fn)
- ; go False (HsWrap co_fn fun) prs }
+ ; go method_sharing False (HsWrap co_fn fun) prs }
-- See Note [No method sharing]
- want_method_inst theta = not (null theta) -- Overloaded
- && not opt_NoMethodSharing
+ want_method_inst method_sharing theta = not (null theta) -- Overloaded
+ && method_sharing
\end{code}
Note [Multiple instantiation]
tagToEnumError tys
- = hang (ptext SLIT("Bad call to tagToEnum#") <+> at_type)
- 2 (vcat [ptext SLIT("Specify the type by giving a type signature"),
- ptext SLIT("e.g. (tagToEnum# x) :: Bool")])
+ = hang (ptext (sLit "Bad call to tagToEnum#") <+> at_type)
+ 2 (vcat [ptext (sLit "Specify the type by giving a type signature"),
+ ptext (sLit "e.g. (tagToEnum# x) :: Bool")])
where
at_type | null tys = empty -- Probably never happens
- | otherwise = ptext SLIT("at type") <+> ppr (head tys)
+ | otherwise = ptext (sLit "at type") <+> ppr (head tys)
\end{code}
%************************************************************************
Unrefineable -> return (HsVar id, ty)
Rigid co -> return (mkHsWrap co (HsVar id), ty)
Wobbly -> traceTc (text "lookupFun" <+> ppr id) >> return (HsVar id, ty) -- Wobbly, or no free vars
- WobblyInvisible -> failWithTc (ppr id_name <+> ptext SLIT(" not in scope because it has a wobbly type (solution: add a type annotation)"))
+ WobblyInvisible -> failWithTc (ppr id_name <+> ptext (sLit " not in scope because it has a wobbly type (solution: add a type annotation)"))
}
- other -> failWithTc (ppr other <+> ptext SLIT("used where a value identifer was expected"))
+ other -> failWithTc (ppr other <+> ptext (sLit "used where a value identifer was expected"))
}
#ifndef GHCI /* GHCI and TH is off */
do_bind fld@(HsRecField { hsRecFieldId = L loc field_lbl, hsRecFieldArg = rhs })
| Just field_ty <- assocMaybe flds_w_tys field_lbl
= addErrCtxt (fieldCtxt field_lbl) $
- do { rhs' <- tcPolyExprNC rhs field_ty
- ; sel_id <- tcLookupField field_lbl
- ; ASSERT( isRecordSelector sel_id )
- return (Just (fld { hsRecFieldId = L loc sel_id, hsRecFieldArg = rhs' })) }
+ do { rhs' <- tcPolyExprNC rhs field_ty
+ ; let field_id = mkUserLocal (nameOccName field_lbl)
+ (nameUnique field_lbl)
+ field_ty loc
+ -- Yuk: the field_id has the *unique* of the selector Id
+ -- (so we can find it easily)
+ -- but is a LocalId with the appropriate type of the RHS
+ -- (so the desugarer knows the type of local binder to make)
+ ; return (Just (fld { hsRecFieldId = L loc field_id, hsRecFieldArg = rhs' })) }
| otherwise
= do { addErrTc (badFieldCon data_con field_lbl)
; return Nothing }
Boring and alphabetical:
\begin{code}
-caseScrutCtxt expr
- = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
+addExprErrCtxt :: OutputableBndr id => LHsExpr id -> TcM a -> TcM a
+addExprErrCtxt expr = addErrCtxt (exprCtxt (unLoc expr))
exprCtxt expr
- = hang (ptext SLIT("In the expression:")) 4 (ppr expr)
+ = hang (ptext (sLit "In the expression:")) 4 (ppr expr)
fieldCtxt field_name
- = ptext SLIT("In the") <+> quotes (ppr field_name) <+> ptext SLIT("field of a record")
+ = ptext (sLit "In the") <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")
funAppCtxt fun arg arg_no
- = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
+ = hang (hsep [ ptext (sLit "In the"), speakNth arg_no, ptext (sLit "argument of"),
quotes (ppr fun) <> text ", namely"])
4 (quotes (ppr arg))
-predCtxt expr
- = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
+badFieldTypes prs
+ = hang (ptext (sLit "Record update for insufficiently polymorphic field")
+ <> plural prs <> colon)
+ 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])
-nonVanillaUpd tycon
- = vcat [ptext SLIT("Record update for the non-Haskell-98 data type")
- <+> quotes (pprSourceTyCon tycon)
- <+> ptext SLIT("is not (yet) supported"),
- ptext SLIT("Use pattern-matching instead")]
badFieldsUpd rbinds
- = hang (ptext SLIT("No constructor has all these fields:"))
+ = hang (ptext (sLit "No constructor has all these fields:"))
4 (pprQuotedList (hsRecFields rbinds))
naughtyRecordSel sel_id
- = ptext SLIT("Cannot use record selector") <+> quotes (ppr sel_id) <+>
- ptext SLIT("as a function due to escaped type variables") $$
- ptext SLIT("Probably fix: use pattern-matching syntax instead")
+ = ptext (sLit "Cannot use record selector") <+> quotes (ppr sel_id) <+>
+ ptext (sLit "as a function due to escaped type variables") $$
+ ptext (sLit "Probable fix: use pattern-matching syntax instead")
notSelector field
- = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
+ = hsep [quotes (ppr field), ptext (sLit "is not a record selector")]
missingStrictFields :: DataCon -> [FieldLabel] -> SDoc
missingStrictFields con fields
-- with strict fields
| otherwise = colon <+> pprWithCommas ppr fields
- header = ptext SLIT("Constructor") <+> quotes (ppr con) <+>
- ptext SLIT("does not have the required strict field(s)")
+ header = ptext (sLit "Constructor") <+> quotes (ppr con) <+>
+ ptext (sLit "does not have the required strict field(s)")
missingFields :: DataCon -> [FieldLabel] -> SDoc
missingFields con fields
- = ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:")
+ = ptext (sLit "Fields of") <+> quotes (ppr con) <+> ptext (sLit "not initialised:")
<+> pprWithCommas ppr fields
--- callCtxt fun args = ptext SLIT("In the call") <+> parens (ppr (foldl mkHsApp fun args))
+-- callCtxt fun args = ptext (sLit "In the call") <+> parens (ppr (foldl mkHsApp fun args))
#ifdef GHCI
polySpliceErr :: Id -> SDoc
polySpliceErr id
- = ptext SLIT("Can't splice the polymorphic local variable") <+> quotes (ppr id)
+ = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id)
#endif
\end{code}
projects / ghc-hetmet.git / blobdiff