\section[TcExpr]{Typecheck an expression}
\begin{code}
+{-# OPTIONS_GHC -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
+-- for details
+
module TcExpr ( tcPolyExpr, tcPolyExprNC,
tcMonoExpr, tcInferRho, tcSyntaxOp ) where
import TcPat
import TcMType
import TcType
+import TcIface ( checkWiredInTyCon )
import Id
import DataCon
import Name
import TyCon
import Type
+import TypeRep
+import Coercion
import Var
import VarSet
import TysWiredIn
tcPolyExpr expr res_ty
= addErrCtxt (exprCtxt (unLoc expr)) $
- tcPolyExprNC expr res_ty
+ (do {traceTc (text "tcPolyExpr") ; tcPolyExprNC expr res_ty })
tcPolyExprNC expr res_ty
| isSigmaTy res_ty
- = do { (gen_fn, expr') <- tcGen res_ty emptyVarSet (\_ -> tcPolyExprNC expr)
+ = do { traceTc (text "tcPolyExprNC" <+> ppr res_ty)
+ ; (gen_fn, expr') <- tcGen res_ty emptyVarSet (\_ -> tcPolyExprNC expr)
-- 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 => ....
\end{code}
-
%************************************************************************
%* *
tcExpr: the main expression typechecker
tcExpr :: HsExpr Name -> BoxyRhoType -> TcM (HsExpr TcId)
tcExpr (HsVar name) res_ty = tcId (OccurrenceOf name) name res_ty
-tcExpr (HsLit lit) res_ty = do { boxyUnify (hsLitType lit) res_ty
- ; return (HsLit lit) }
+tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit
+ ; coi <- boxyUnify lit_ty res_ty
+ ; return $ wrapExprCoI (HsLit lit) coi
+ }
tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
; return (HsPar expr') }
go lfun@(L loc fun) args
= do { (fun', args') <- -- addErrCtxt (callCtxt lfun args) $
tcApp fun (length args) (tcArgs lfun args) res_ty
+ ; traceTc (text "tcExpr args': " <+> ppr args')
; return (unLoc (foldl mkHsApp (L loc fun') args')) }
tcExpr (HsLam match) res_ty
; return (ExplicitList elt_ty exprs') }
where
tc_elt elt_ty expr = tcPolyExpr expr elt_ty
+{- TODO: Version from Tom's original patch. Unfortunately, we cannot do it this
+ way, but need to teach boxy splitters about match deferral and coercions.
+ = do { elt_tv <- newBoxyTyVar argTypeKind
+ ; let elt_ty = TyVarTy elt_tv
+ ; coi <- boxyUnify (mkTyConApp listTyCon [elt_ty]) res_ty
+ -- ; elt_ty <- boxySplitListTy res_ty
+ ; exprs' <- mappM (tc_elt elt_ty) exprs
+ ; return $ wrapExprCoI (ExplicitList elt_ty exprs') coi }
+ -- ; return (ExplicitList elt_ty exprs') }
+ where
+ tc_elt elt_ty expr = tcPolyExpr expr elt_ty
+ -}
tcExpr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty
= do { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
= do { tvs <- newBoxyTyVars [argTypeKind | e <- exprs]
; let tup_tc = tupleTyCon boxity (length exprs)
tup_res_ty = mkTyConApp tup_tc (mkTyVarTys tvs)
- ; arg_tys <- preSubType tvs (mkVarSet tvs) tup_res_ty res_ty
- ; exprs' <- tcPolyExprs exprs arg_tys
+ ; 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 <- tcFunResTy (tyConName tup_tc) (mkTyConApp tup_tc arg_tys') res_ty
+ ; co_fn <- tcFunResTy (tyConName tup_tc) (mkTyConApp tup_tc arg_tys') res_ty
; return (mkHsWrap co_fn (ExplicitTuple exprs' boxity)) }
tcExpr (HsProc pat cmd) res_ty
-- don't know how to do the update otherwise.
-tcExpr expr@(RecordUpd record_expr hrbinds@(HsRecordBinds rbinds) _ _ _) res_ty
+tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty
= -- STEP 0
-- Check that the field names are really field names
- ASSERT( notNull rbinds )
let
- field_names = map fst rbinds
+ field_names = hsRecFields rbinds
in
- mappM (tcLookupField . unLoc) field_names `thenM` \ sel_ids ->
+ ASSERT( notNull field_names )
+ mappM tcLookupField field_names `thenM` \ sel_ids ->
-- The renamer has already checked that they
-- are all in scope
let
bad_guys = [ setSrcSpan loc $ addErrTc (notSelector field_name)
- | (L loc field_name, sel_id) <- field_names `zip` sel_ids,
- not (isRecordSelector sel_id) -- Excludes class ops
+ | (fld, sel_id) <- rec_flds rbinds `zip` sel_ids,
+ not (isRecordSelector sel_id), -- Excludes class ops
+ let L loc field_name = hsRecFieldId fld
]
in
checkM (null bad_guys) (sequenceM bad_guys `thenM_` failM) `thenM_`
-- 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)
- upd_field_lbls = recBindFields hrbinds
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_field_lbls
+ is_relevant con = all (`elem` dataConFieldLabels con) field_names
in
-- 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 hrbinds) `thenM_`
+ (badFieldsUpd rbinds) `thenM_`
-- 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
(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` upd_field_lbls) ]
+ , not (fld `elem` field_names) ]
is_common_tv tv = tv `elemVarSet` common_tyvars
con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys
in
tcSubExp result_ty res_ty `thenM` \ co_fn ->
- tcRecordBinds con1 con1_arg_tys' hrbinds `thenM` \ rbinds' ->
+ tcRecordBinds con1 con1_arg_tys' rbinds `thenM` \ rbinds' ->
-- STEP 5: Typecheck the expression to be updated
let
= idHsWrapper
in
-- Phew!
- returnM (mkHsWrap co_fn (RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
+ returnM (mkHsWrap co_fn (RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
relevant_cons scrut_inst_tys result_inst_tys))
\end{code}
-- tcFun work nicely for OpApp and Sections too
; fun' <- instFun orig fun res_subst tv_theta_prs
; co_fn' <- wrapFunResCoercion (substTys res_subst fun_arg_tys) co_fn
+ ; traceTc (text "tcIdApp: " <+> ppr (mkHsWrap co_fn' fun') <+> ppr tv_theta_prs <+> ppr co_fn' <+> ppr fun')
; return (mkHsWrap co_fn' fun', args') }
\end{code}
-- And pack up the results
; fun' <- instFun orig fun res_subst tv_theta_prs
+ ; traceTc (text "tcId yields" <+> ppr (mkHsWrap co_fn fun'))
; return (mkHsWrap co_fn fun') }
-- Note [Push result type in]
instFun orig fun subst tv_theta_prs
= do { let ty_theta_prs' = map subst_pr tv_theta_prs
-
+ ; traceTc (text "instFun" <+> ppr ty_theta_prs')
-- Make two ad-hoc checks
; doStupidChecks fun ty_theta_prs'
-- Now do normal instantiation
- ; go True fun ty_theta_prs' }
+ ; result <- go True fun ty_theta_prs'
+ ; traceTc (text "instFun result" <+> ppr result)
+ ; return result
+ }
where
subst_pr (tvs, theta)
= (substTyVars subst tvs, substTheta subst theta)
- go _ 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
- = do { meth_id <- newMethodWithGivenTy orig fun_id tys
+ = 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 round with 'False' to prevent further use
-- of newMethod: see Note [Multiple instantiation]
go _ 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 }
-- See Note [No method sharing]
ATcId { tct_id = id, tct_type = ty, tct_co = mb_co, tct_level = lvl }
-> do { thLocalId orig id ty lvl
; case mb_co of
- Nothing -> return (HsVar id, ty) -- Wobbly, or no free vars
- Just co -> return (mkHsWrap co (HsVar id), ty) }
+ 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)"))
+ }
other -> failWithTc (ppr other <+> ptext SLIT("used where a value identifer was expected"))
}
-> HsRecordBinds Name
-> TcM (HsRecordBinds TcId)
-tcRecordBinds data_con arg_tys (HsRecordBinds rbinds)
+tcRecordBinds data_con arg_tys (HsRecFields rbinds dd)
= do { mb_binds <- mappM do_bind rbinds
- ; return (HsRecordBinds (catMaybes mb_binds)) }
+ ; return (HsRecFields (catMaybes mb_binds) dd) }
where
flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
- do_bind (L loc field_lbl, rhs)
+ 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 (L loc sel_id, rhs')) }
+ return (Just (fld { hsRecFieldId = L loc sel_id, hsRecFieldArg = rhs' })) }
| otherwise
= do { addErrTc (badFieldCon data_con field_lbl)
; return Nothing }
not (fl `elem` field_names_used)
]
- field_names_used = recBindFields rbinds
+ field_names_used = hsRecFields rbinds
field_labels = dataConFieldLabels data_con
field_info = zipEqual "missingFields"
ptext SLIT("Use pattern-matching instead")]
badFieldsUpd rbinds
= hang (ptext SLIT("No constructor has all these fields:"))
- 4 (pprQuotedList (recBindFields rbinds))
+ 4 (pprQuotedList (hsRecFields rbinds))
naughtyRecordSel sel_id
= ptext SLIT("Cannot use record selector") <+> quotes (ppr sel_id) <+>
= ptext SLIT("Can't splice the polymorphic local variable") <+> quotes (ppr id)
#endif
\end{code}
+
+\begin{code}
+wrapExprCoI :: HsExpr a -> CoercionI -> HsExpr a
+wrapExprCoI expr IdCo = expr
+wrapExprCoI expr (ACo co) = mkHsWrap (WpCo co) expr
+\end{code}
projects / ghc-hetmet.git / blobdiff