%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcExpr]{Typecheck an expression}
\begin{code}
-module TcExpr ( tcPolyExpr, tcPolyExprNC,
- tcMonoExpr, tcInferRho, tcSyntaxOp ) where
+{-# OPTIONS -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/Commentary/CodingStyle#Warnings
+-- for details
+
+module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcInferRho, tcSyntaxOp ) where
#include "HsVersions.h"
#ifdef GHCI /* Only if bootstrapped */
import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket )
-import HsSyn ( nlHsVar )
-import Id ( Id, idName )
-import Name ( isExternalName )
-import TcType ( isTauTy )
-import TcEnv ( checkWellStaged )
-import HsSyn ( nlHsApp )
import qualified DsMeta
#endif
-import HsSyn ( HsExpr(..), LHsExpr, ArithSeqInfo(..), recBindFields,
- HsMatchContext(..), HsRecordBinds, mkHsWrap, hsExplicitTvs,
- mkHsApp, mkLHsWrap )
-import TcHsSyn ( hsLitType )
+import HsSyn
+import TcHsSyn
import TcRnMonad
-import TcUnify ( tcInfer, tcSubExp, tcFunResTy, tcGen, boxyUnify, subFunTys, zapToMonotype, stripBoxyType,
- boxySplitListTy, boxySplitTyConApp, wrapFunResCoercion, preSubType,
- unBox )
-import BasicTypes ( Arity, isMarkedStrict )
-import Inst ( newMethodFromName, newIPDict, instCall,
- newMethodWithGivenTy, instStupidTheta )
-import TcBinds ( tcLocalBinds )
-import TcEnv ( tcLookup, tcLookupDataCon, tcLookupField, tcExtendTyVarEnv2 )
-import TcArrows ( tcProc )
-import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcBody,
- TcMatchCtxt(..) )
-import TcHsType ( tcHsSigType, UserTypeCtxt(..) )
-import TcPat ( tcOverloadedLit, addDataConStupidTheta, badFieldCon )
-import TcMType ( tcInstTyVars, newFlexiTyVarTy, newBoxyTyVars,
- readFilledBox, zonkTcTypes )
-import TcType ( TcType, TcSigmaType, TcRhoType, TvSubst,
- BoxySigmaType, BoxyRhoType, ThetaType,
- mkTyVarTys, mkFunTys,
- tcMultiSplitSigmaTy, tcSplitFunTysN,
- tcSplitTyConApp_maybe,
- isSigmaTy, mkFunTy, mkTyConApp,
- exactTyVarsOfType, exactTyVarsOfTypes,
- zipTopTvSubst, zipOpenTvSubst, substTys, substTyVar
- )
-import {- Kind parts of -}
- Type ( argTypeKind )
-
-import Id ( idType, recordSelectorFieldLabel,
- isRecordSelector, isNaughtyRecordSelector,
- isDataConId_maybe )
-import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks,
- dataConSourceArity,
- dataConWrapId, isVanillaDataCon, dataConUnivTyVars,
- dataConOrigArgTys )
-import Name ( Name )
-import TyCon ( FieldLabel, tyConStupidTheta, tyConDataCons,
- isEnumerationTyCon )
-import Type ( substTheta, substTy )
-import Var ( TyVar, tyVarKind )
-import VarSet ( emptyVarSet, elemVarSet, unionVarSet )
-import TysWiredIn ( boolTy, parrTyCon, tupleTyCon )
-import PrelNames ( enumFromName, enumFromThenName,
- enumFromToName, enumFromThenToName,
- enumFromToPName, enumFromThenToPName, negateName,
- hasKey
- )
-import PrimOp ( tagToEnumKey )
-
+import TcUnify
+import BasicTypes
+import Inst
+import TcBinds
+import TcEnv
+import TcArrows
+import TcMatches
+import TcHsType
+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
+import PrelNames
+import PrimOp
import DynFlags
-import StaticFlags ( opt_NoMethodSharing )
-import HscTypes ( TyThing(..) )
-import SrcLoc ( Located(..), unLoc )
+import StaticFlags
+import HscTypes
+import SrcLoc
import Util
-import ListSetOps ( assocMaybe )
-import Maybes ( catMaybes )
+import ListSetOps
+import Maybes
import Outputable
import FastString
-#ifdef DEBUG
-import TyCon ( tyConArity )
-#endif
+import Control.Monad
\end{code}
%************************************************************************
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 => ....
; return (mkLHsWrap gen_fn expr') }
| otherwise
---------------
tcPolyExprs :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId]
-tcPolyExprs [] [] = returnM []
+tcPolyExprs [] [] = return []
tcPolyExprs (expr:exprs) (ty:tys)
= do { expr' <- tcPolyExpr expr ty
; exprs' <- tcPolyExprs exprs tys
- ; returnM (expr':exprs') }
+ ; return (expr':exprs') }
tcPolyExprs exprs tys = pprPanic "tcPolyExprs" (ppr exprs $$ ppr tys)
---------------
\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 $ mkHsWrapCoI coi (HsLit lit)
+ }
tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
; return (HsPar expr') }
tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
- ; returnM (HsSCC lbl expr') }
+ ; return (HsSCC lbl expr') }
+tcExpr (HsTickPragma info expr) res_ty
+ = do { expr' <- tcMonoExpr expr res_ty
+ ; return (HsTickPragma info expr') }
tcExpr (HsCoreAnn lbl expr) res_ty -- hdaume: core annotation
= do { expr' <- tcMonoExpr expr res_ty
; return (HsOverLit lit') }
tcExpr (NegApp expr neg_expr) res_ty
- = do { neg_expr' <- tcSyntaxOp (OccurrenceOf negateName) neg_expr
+ = do { neg_expr' <- tcSyntaxOp NegateOrigin neg_expr
(mkFunTy res_ty res_ty)
; expr' <- tcMonoExpr expr res_ty
; return (NegApp expr' neg_expr') }
tcExpr (HsIPVar ip) res_ty
- = do { -- Implicit parameters must have a *tau-type* not a
+ = do { let origin = IPOccOrigin ip
+ -- Implicit parameters must have a *tau-type* not a
-- type scheme. We enforce this by creating a fresh
-- type variable as its type. (Because res_ty may not
-- be a tau-type.)
- ip_ty <- newFlexiTyVarTy argTypeKind -- argTypeKind: it can't be an unboxed tuple
- ; co_fn <- tcSubExp ip_ty res_ty
- ; (ip', inst) <- newIPDict (IPOccOrigin ip) ip ip_ty
+ ; ip_ty <- newFlexiTyVarTy argTypeKind -- argTypeKind: it can't be an unboxed tuple
+ ; co_fn <- tcSubExp origin ip_ty res_ty
+ ; (ip', inst) <- newIPDict origin ip ip_ty
; extendLIE inst
; return (mkHsWrap co_fn (HsIPVar ip')) }
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
tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
tcPolyExprNC expr res_ty)
- ; co_fn <- tcSubExp sig_tc_ty res_ty
+ ; co_fn <- tcSubExp ExprSigOrigin sig_tc_ty res_ty
; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) }
tcExpr (HsType 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")
- tc_args arg1_ty' [arg1_ty, arg2_ty]
- = do { boxyUnify arg1_ty' arg1_ty
- ; tcArg lop (arg2, arg2_ty, 2) }
- tc_args arg1_ty' other = panic "tcExpr SectionR"
+ 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') }
+ tc_args arg1_ty' _ _ _ = panic "tcExpr SectionR"
\end{code}
\begin{code}
= tcDoStmts do_or_lc stmts body res_ty
tcExpr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list
- = do { elt_ty <- boxySplitListTy res_ty
- ; exprs' <- mappM (tc_elt elt_ty) exprs
- ; return (ExplicitList elt_ty exprs') }
+ = do { (elt_ty, coi) <- boxySplitListTy res_ty
+ ; exprs' <- mapM (tc_elt elt_ty) exprs
+ ; return $ mkHsWrapCoI coi (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
- ; exprs' <- mappM (tc_elt elt_ty) exprs
- ; ifM (null exprs) (zapToMonotype elt_ty)
+ = do { (elt_ty, coi) <- boxySplitPArrTy 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
-- (Not needed for [] and () becuase they happen
-- to parse as data constructors.)
- ; return (ExplicitPArr elt_ty exprs') }
+ ; return $ mkHsWrapCoI coi (ExplicitPArr elt_ty exprs') }
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 { arg_tys <- boxySplitTyConApp (tupleTyCon boxity (length exprs)) res_ty
- ; exprs' <- tcPolyExprs exprs arg_tys
- ; return (ExplicitTuple exprs' boxity) }
+ = do { tvs <- newBoxyTyVars [argTypeKind | 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') <- tcProc pat cmd res_ty
- ; return (HsProc pat' cmd') }
+ = do { (pat', cmd', coi) <- tcProc pat cmd res_ty
+ ; 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}
%************************************************************************
; checkMissingFields data_con rbinds
; let arity = dataConSourceArity data_con
- check_fields arg_tys
- = do { rbinds' <- tcRecordBinds data_con arg_tys rbinds
- ; mapM unBox arg_tys
- ; return rbinds' }
- -- The unBox ensures that all the boxes in arg_tys are indeed
+ check_fields qtvs qtys arg_tys
+ = do { let arg_tys' = substTys (zipOpenTvSubst qtvs qtys) arg_tys
+ ; rbinds' <- tcRecordBinds data_con arg_tys' rbinds
+ ; qtys' <- mapM refineBoxToTau qtys
+ ; return (qtys', rbinds') }
+ -- The refineBoxToTau ensures that all the boxes in arg_tys are indeed
-- filled, which is the invariant expected by tcIdApp
+ -- How could this not be the case? Consider a record construction
+ -- that does not mention all the fields.
; (con_expr, rbinds') <- tcIdApp con_name arity check_fields res_ty
- ; returnM (RecordCon (L loc (dataConWrapId data_con)) con_expr rbinds') }
+ ; return (RecordCon (L loc (dataConWrapId data_con)) con_expr rbinds') }
-- The main complication with RecordUpd is that we need to explicitly
-- handle the *non-updated* fields. Consider:
-- don't know how to do the update otherwise.
-tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
- = -- STEP 0
+tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty = do
+ -- STEP 0
-- Check that the field names are really field names
- ASSERT( notNull rbinds )
let
- field_names = map fst rbinds
- in
- mappM (tcLookupField . unLoc) field_names `thenM` \ sel_ids ->
+ 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)
- | (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_`
+
+ 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)
- upd_field_lbls = recBindFields rbinds
sel_id : _ = sel_ids
(tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if
- data_cons = tyConDataCons tycon -- it's not a field label
+ 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
- in
+ is_relevant con = all (`elem` dataConFieldLabels con) field_names
-- 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) `thenM_`
+ (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) `thenM_`
+ (nonVanillaUpd tycon)
-- STEP 4
-- Use the un-updated fields to find a vector of booleans saying
let
-- A constructor is only relevant to this process if
-- it contains *all* the fields that are being updated
- con1 = head relevant_cons -- A representative constructor
- con1_tyvars = dataConUnivTyVars con1
- con1_flds = dataConFieldLabels con1
- con1_arg_tys = dataConOrigArgTys con1
- common_tyvars = exactTyVarsOfTypes [ty | (fld,ty) <- con1_flds `zip` con1_arg_tys
- , not (fld `elem` upd_field_lbls) ]
+ 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 = returnM result_inst_ty -- Same as result type
+ | is_common_tv tv = return result_inst_ty -- Same as result type
| otherwise = newFlexiTyVarTy (tyVarKind tv) -- Fresh type, of correct kind
- in
- tcInstTyVars con1_tyvars `thenM` \ (_, result_inst_tys, inst_env) ->
- zipWithM mk_inst_ty con1_tyvars result_inst_tys `thenM` \ 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.)
+
+ 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_record_ty = mkTyConApp tycon result_inst_tys
- con1_arg_tys' = map (substTy inst_env) con1_arg_tys
- in
- tcSubExp result_record_ty res_ty `thenM` \ co_fn ->
- tcRecordBinds con1 con1_arg_tys' rbinds `thenM` \ rbinds' ->
-
- -- STEP 5
- -- Typecheck the expression to be updated
+ 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
- record_ty = ASSERT( length inst_tys == tyConArity tycon )
- mkTyConApp tycon inst_tys
+ 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 tycon
- in
- tcMonoExpr record_expr record_ty `thenM` \ record_expr' ->
-
- -- 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.
+ -- 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 tyConStupidTheta tells us.
+ -- What dictionaries do we need? The dataConStupidTheta tells us.
let
- theta' = substTheta inst_env (tyConStupidTheta tycon)
- in
- instStupidTheta RecordUpdOrigin theta' `thenM_`
+ theta' = substTheta scrut_inst_env (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
+ = WpCast $ mkTyConApp co_con scrut_inst_tys
+ | otherwise
+ = idHsWrapper
-- Phew!
- returnM (mkHsWrap co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty))
+ return (mkHsWrap co_fn (RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
+ relevant_cons scrut_inst_tys result_inst_tys))
\end{code}
\begin{code}
tcExpr (ArithSeq _ seq@(From expr)) res_ty
- = do { elt_ty <- boxySplitListTy res_ty
+ = do { (elt_ty, coi) <- boxySplitListTy res_ty
; expr' <- tcPolyExpr expr elt_ty
; enum_from <- newMethodFromName (ArithSeqOrigin seq)
elt_ty enumFromName
- ; return (ArithSeq (HsVar enum_from) (From expr')) }
+ ; return $ mkHsWrapCoI coi (ArithSeq (HsVar enum_from) (From expr')) }
tcExpr in_expr@(ArithSeq _ seq@(FromThen expr1 expr2)) res_ty
- = do { elt_ty <- boxySplitListTy res_ty
+ = do { (elt_ty, coi) <- boxySplitListTy res_ty
; expr1' <- tcPolyExpr expr1 elt_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
elt_ty enumFromThenName
- ; return (ArithSeq (HsVar enum_from_then) (FromThen expr1' expr2')) }
-
+ ; return $ mkHsWrapCoI coi
+ (ArithSeq (HsVar enum_from_then) (FromThen expr1' expr2')) }
tcExpr in_expr@(ArithSeq _ seq@(FromTo expr1 expr2)) res_ty
- = do { elt_ty <- boxySplitListTy res_ty
+ = do { (elt_ty, coi) <- boxySplitListTy res_ty
; expr1' <- tcPolyExpr expr1 elt_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
elt_ty enumFromToName
- ; return (ArithSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
+ ; return $ mkHsWrapCoI coi
+ (ArithSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
tcExpr in_expr@(ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
- = do { elt_ty <- boxySplitListTy res_ty
+ = do { (elt_ty, coi) <- boxySplitListTy res_ty
; expr1' <- tcPolyExpr expr1 elt_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; expr3' <- tcPolyExpr expr3 elt_ty
; eft <- newMethodFromName (ArithSeqOrigin seq)
elt_ty enumFromThenToName
- ; return (ArithSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
+ ; return $ mkHsWrapCoI coi
+ (ArithSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
tcExpr in_expr@(PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
- = do { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
+ = do { (elt_ty, coi) <- boxySplitPArrTy res_ty
; expr1' <- tcPolyExpr expr1 elt_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
elt_ty enumFromToPName
- ; return (PArrSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
+ ; return $ mkHsWrapCoI coi
+ (PArrSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
tcExpr in_expr@(PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
- = do { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
+ = do { (elt_ty, coi) <- boxySplitPArrTy res_ty
; expr1' <- tcPolyExpr expr1 elt_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; expr3' <- tcPolyExpr expr3 elt_ty
; eft <- newMethodFromName (PArrSeqOrigin seq)
elt_ty enumFromThenToPName
- ; return (PArrSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
+ ; return $ mkHsWrapCoI coi
+ (PArrSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
tcExpr (PArrSeq _ _) _
= panic "TcExpr.tcMonoExpr: Infinite parallel array!"
tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
tcExpr (HsBracket brack) res_ty = do { e <- tcBracket brack res_ty
; return (unLoc e) }
+tcExpr e@(HsQuasiQuoteE _) res_ty =
+ pprPanic "Should never see HsQuasiQuoteE in type checker" (ppr e)
#endif /* GHCI */
\end{code}
---------------------------
tcApp :: HsExpr Name -- Function
-> Arity -- Number of args reqd
- -> ([BoxySigmaType] -> TcM arg_results) -- Argument type-checker
+ -> ArgChecker results
-> BoxyRhoType -- Result type
- -> TcM (HsExpr TcId, arg_results)
+ -> TcM (HsExpr TcId, results)
-- (tcFun fun n_args arg_checker res_ty)
-- The argument type checker, arg_checker, will be passed exactly n_args types
= tcIdApp fun_name n_args arg_checker res_ty
tcApp fun n_args arg_checker res_ty -- The vanilla case (rula APP)
- = do { arg_boxes <- newBoxyTyVars (replicate n_args argTypeKind)
- ; fun' <- tcExpr fun (mkFunTys (mkTyVarTys arg_boxes) res_ty)
- ; arg_tys' <- mapM readFilledBox arg_boxes
- ; args' <- arg_checker arg_tys'
+ = do { arg_boxes <- newBoxyTyVars (replicate n_args argTypeKind)
+ ; fun' <- tcExpr fun (mkFunTys (mkTyVarTys arg_boxes) res_ty)
+ ; arg_tys' <- mapM readFilledBox arg_boxes
+ ; (_, args') <- arg_checker [] [] arg_tys' -- Yuk
; return (fun', args') }
---------------------------
tcIdApp :: Name -- Function
-> Arity -- Number of args reqd
- -> ([BoxySigmaType] -> TcM arg_results) -- Argument type-checker
- -- The arg-checker guarantees to fill all boxes in the arg types
+ -> ArgChecker results -- The arg-checker guarantees to fill all boxes in the arg types
-> BoxyRhoType -- Result type
- -> TcM (HsExpr TcId, arg_results)
+ -> TcM (HsExpr TcId, results)
-- Call (f e1 ... en) :: res_ty
-- Type f :: forall a b c. theta => fa_1 -> ... -> fa_k -> fres
; let extra_arg_tys' = mkTyVarTys extra_arg_boxes
res_ty' = mkFunTys extra_arg_tys' res_ty
; qtys' <- preSubType qtvs tau_qtvs fun_res_ty res_ty'
- ; let arg_subst = zipOpenTvSubst qtvs qtys'
- fun_arg_tys' = substTys arg_subst fun_arg_tys
-- Typecheck the arguments!
-- Doing so will fill arg_qtvs and extra_arg_tys'
- ; args' <- arg_checker (fun_arg_tys' ++ extra_arg_tys')
+ ; (qtys'', args') <- arg_checker qtvs qtys' (fun_arg_tys ++ extra_arg_tys')
-- Strip boxes from the qtvs that have been filled in by the arg checking
- -- AND any variables that are mentioned in neither arg nor result
- -- the latter are mentioned only in constraints; stripBoxyType will
- -- fill them with a monotype
- ; let strip qtv qty' | qtv `elemVarSet` arg_qtvs = stripBoxyType qty'
- | otherwise = return qty'
- ; qtys'' <- zipWithM strip qtvs qtys'
; extra_arg_tys'' <- mapM readFilledBox extra_arg_boxes
-- Result subsumption
+ -- This fills in res_qtvs
; let res_subst = zipOpenTvSubst qtvs qtys''
fun_res_ty'' = substTy res_subst fun_res_ty
res_ty'' = mkFunTys extra_arg_tys'' res_ty
- ; co_fn <- tcFunResTy fun_name fun_res_ty'' res_ty''
+ ; co_fn <- tcSubExp orig fun_res_ty'' res_ty''
-- And pack up the results
-- By applying the coercion just to the *function* we can make
-- tcFun work nicely for OpApp and Sections too
; fun' <- instFun orig fun res_subst tv_theta_prs
- ; co_fn' <- wrapFunResCoercion fun_arg_tys' co_fn
+ ; 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}
; let res_subst = zipTopTvSubst qtvs qtv_tys
fun_tau' = substTy res_subst fun_tau
- ; co_fn <- tcFunResTy fun_name fun_tau' res_ty
+ ; co_fn <- tcSubExp orig fun_tau' res_ty
-- 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' }
+ ; method_sharing <- doptM Opt_MethodSharing
+ ; result <- go method_sharing True fun ty_theta_prs'
+ ; traceTc (text "instFun result" <+> ppr result)
+ ; return result
+ }
where
subst_pr (tvs, theta)
- = (map (substTyVar subst) tvs, substTheta subst 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
- ; go False (HsVar meth_id) prs }
+ 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 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
- ; go False (HsWrap co_fn fun) prs }
+ ; traceTc (text "go yields co_fn" <+> ppr co_fn)
+ ; 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]
a) it's better for RULEs involving overloaded functions
b) perhaps fewer separated lambdas
+Note [Left to right]
+~~~~~~~~~~~~~~~~~~~~
+tcArgs implements a left-to-right order, which goes beyond what is described in the
+impredicative type inference paper. In particular, it allows
+ runST $ foo
+where runST :: (forall s. ST s a) -> a
+When typechecking the application of ($)::(a->b) -> a -> b, we first check that
+runST has type (a->b), thereby filling in a=forall s. ST s a. Then we un-box this type
+before checking foo. The left-to-right order really helps here.
+
\begin{code}
tcArgs :: LHsExpr Name -- The function (for error messages)
- -> [LHsExpr Name] -> [TcSigmaType] -- Actual arguments and expected arg types
- -> TcM [LHsExpr TcId] -- Resulting args
+ -> [LHsExpr Name] -- Actual args
+ -> ArgChecker [LHsExpr TcId]
-tcArgs fun args expected_arg_tys
- = mapM (tcArg fun) (zip3 args expected_arg_tys [1..])
+type ArgChecker results
+ = [TyVar] -> [TcSigmaType] -- Current instantiation
+ -> [TcSigmaType] -- Expected arg types (**before** applying the instantiation)
+ -> TcM ([TcSigmaType], results) -- Resulting instaniation and args
-tcArg :: LHsExpr Name -- The function (for error messages)
- -> (LHsExpr Name, BoxySigmaType, Int) -- Actual argument and expected arg type
- -> TcM (LHsExpr TcId) -- Resulting argument
-tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no) $
- tcPolyExprNC arg ty
+tcArgs fun args qtvs qtys arg_tys
+ = go 1 qtys args arg_tys
+ where
+ go n qtys [] [] = return (qtys, [])
+ go n qtys (arg:args) (arg_ty:arg_tys)
+ = do { arg' <- tcArg fun n arg qtvs qtys arg_ty
+ ; qtys' <- mapM refineBox qtys -- Exploit new info
+ ; (qtys'', args') <- go (n+1) qtys' args arg_tys
+ ; return (qtys'', arg':args') }
+ go n qtys args arg_tys = panic "tcArgs"
+
+tcArg :: LHsExpr Name -- The function
+ -> Int -- and arg number (for error messages)
+ -> LHsExpr Name
+ -> [TyVar] -> [TcSigmaType] -- Instantiate the arg type like this
+ -> BoxySigmaType
+ -> TcM (LHsExpr TcId) -- Resulting argument
+tcArg fun arg_no arg qtvs qtys ty
+ = addErrCtxt (funAppCtxt fun arg arg_no) $
+ tcPolyExprNC arg (substTyWith qtvs qtys ty)
\end{code}
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}
%************************************************************************
%* *
-\subsection{@tcId@ typchecks an identifier occurrence}
+\subsection{@tcId@ typechecks an identifier occurrence}
%* *
%************************************************************************
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"))
+ other -> failWithTc (ppr other <+> ptext (sLit "used where a value identifer was expected"))
}
#ifndef GHCI /* GHCI and TH is off */
--------------------------------------
thBrackId orig id ps_var lie_var
- | isExternalName id_name
+ | thTopLevelId id
= -- Top-level identifiers in this module,
-- (which have External Names)
-- are just like the imported case:
-- 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_name; return id }
+ do { keepAliveTc id; return id }
| otherwise
= -- Nested identifiers, such as 'x' in
-- Update the pending splices
; ps <- readMutVar ps_var
- ; writeMutVar ps_var ((id_name, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps)
+ ; writeMutVar ps_var ((idName id, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps)
; return id } }
- where
- id_name = idName id
#endif /* GHCI */
\end{code}
-> HsRecordBinds Name
-> TcM (HsRecordBinds TcId)
-tcRecordBinds data_con arg_tys rbinds
- = do { mb_binds <- mappM do_bind rbinds
- ; return (catMaybes mb_binds) }
+tcRecordBinds data_con arg_tys (HsRecFields rbinds dd)
+ = do { mb_binds <- mapM do_bind rbinds
+ ; 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 }
-- Illegal if any arg is strict
addErrTc (missingStrictFields data_con [])
else
- returnM ()
+ return ()
- | otherwise -- A record
- = checkM (null missing_s_fields)
- (addErrTc (missingStrictFields data_con missing_s_fields)) `thenM_`
+ | otherwise = do -- A record
+ unless (null missing_s_fields)
+ (addErrTc (missingStrictFields data_con missing_s_fields))
- doptM Opt_WarnMissingFields `thenM` \ warn ->
- checkM (not (warn && notNull missing_ns_fields))
+ warn <- doptM Opt_WarnMissingFields
+ unless (not (warn && notNull missing_ns_fields))
(warnTc True (missingFields data_con missing_ns_fields))
where
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"
Boring and alphabetical:
\begin{code}
caseScrutCtxt expr
- = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
+ = hang (ptext (sLit "In the scrutinee of a case expression:")) 4 (ppr 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)
+ = hang (ptext (sLit "In the predicate expression:")) 4 (ppr expr)
nonVanillaUpd tycon
- = vcat [ptext SLIT("Record update for the non-Haskell-98 data type") <+> quotes (ppr tycon)
- <+> ptext SLIT("is not (yet) supported"),
- ptext SLIT("Use pattern-matching instead")]
+ = 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:"))
- 4 (pprQuotedList (recBindFields rbinds))
+ = 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 "Probably 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