X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcExpr.lhs;h=f0858f3f16b2cc9cf78cdc8f77b1c3132f41ac79;hb=4c7b8ec3e7852f88f4c355de2745dc594d120819;hp=8227e678eaad1795d0063a843c8089a3ea7ccf12;hpb=ac10f8408520a30e8437496d320b8b86afda2e8f;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 8227e67..f0858f3 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -21,11 +21,13 @@ import qualified DsMeta
 #endif
 
 import HsSyn		( HsExpr(..), LHsExpr, ArithSeqInfo(..), recBindFields,
-			  HsMatchContext(..), HsRecordBinds, mkHsApp, mkHsDictApp, mkHsTyApp )
+			  HsMatchContext(..), HsRecordBinds, 
+			  mkHsCoerce, mkHsApp, mkHsDictApp, mkHsTyApp )
 import TcHsSyn		( hsLitType )
 import TcRnMonad
-import TcUnify		( tcInfer, tcSubExp, tcGen, boxyUnify, subFunTys, zapToMonotype, stripBoxyType,
-			  boxySplitListTy, boxySplitTyConApp, wrapFunResCoercion, boxySubMatchType, unBox )
+import TcUnify		( tcInfer, tcSubExp, tcFunResTy, tcGen, boxyUnify, subFunTys, zapToMonotype, stripBoxyType,
+			  boxySplitListTy, boxySplitTyConApp, wrapFunResCoercion, boxySubMatchType, 
+			  unBox )
 import BasicTypes	( Arity, isMarkedStrict )
 import Inst		( newMethodFromName, newIPDict, instToId,
 			  newDicts, newMethodWithGivenTy, tcInstStupidTheta )
@@ -105,7 +107,7 @@ tcPolyExprNC expr res_ty
   = do	{ (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
-	; return (L (getLoc expr') (HsCoerce gen_fn (unLoc expr'))) }
+	; return (L (getLoc expr') (mkHsCoerce gen_fn (unLoc expr'))) }
 
   | otherwise
   = tcMonoExpr expr res_ty
@@ -181,7 +183,7 @@ tcExpr (HsIPVar ip) res_ty
 	; co_fn <- tcSubExp ip_ty res_ty
 	; (ip', inst) <- newIPDict (IPOccOrigin ip) ip ip_ty
 	; extendLIE inst
-	; return (HsCoerce co_fn (HsIPVar ip')) }
+	; return (mkHsCoerce co_fn (HsIPVar ip')) }
 
 tcExpr (HsApp e1 e2) res_ty 
   = go e1 [e2]
@@ -195,13 +197,13 @@ tcExpr (HsApp e1 e2) res_ty
 
 tcExpr (HsLam match) res_ty
   = do	{ (co_fn, match') <- tcMatchLambda match res_ty
-	; return (HsCoerce co_fn (HsLam match')) }
+	; return (mkHsCoerce co_fn (HsLam match')) }
 
 tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty
  = do	{ sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
 	; expr' <- tcPolyExpr expr sig_tc_ty
 	; co_fn <- tcSubExp sig_tc_ty res_ty
-	; return (HsCoerce co_fn (ExprWithTySigOut expr' sig_ty)) }
+	; return (mkHsCoerce co_fn (ExprWithTySigOut expr' sig_ty)) }
 
 tcExpr (HsType ty) res_ty
   = failWithTc (text "Can't handle type argument:" <+> ppr ty)
@@ -247,7 +249,7 @@ tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty
 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' ->
 				   tcApp op 2 (tc_args arg1_ty') res_ty'
-	; return (HsCoerce co_fn (SectionR (L loc op') arg2')) }
+	; return (mkHsCoerce co_fn (SectionR (L loc op') arg2')) }
   where
     doc = ptext SLIT("The section") <+> quotes (ppr in_expr)
 		<+> ptext SLIT("takes one argument")
@@ -489,7 +491,7 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
     extendLIEs dicts			`thenM_`
 
 	-- Phew!
-    returnM (HsCoerce co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty))
+    returnM (mkHsCoerce co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty))
 \end{code}
 
 
@@ -607,7 +609,7 @@ tcApp (HsVar fun_name) n_args arg_checker res_ty
   = 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 n_args
+  = 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'
@@ -647,7 +649,7 @@ tcIdApp fun_name n_args arg_checker res_ty
 
 	-- Match the result type of the function with the
 	-- result type of the context, to get an inital substitution
-	; extra_arg_boxes <- newBoxyTyVars n_missing_args
+	; extra_arg_boxes <- newBoxyTyVars (replicate n_missing_args argTypeKind)
 	; let extra_arg_tys' = mkTyVarTys extra_arg_boxes
 	      res_ty' 	     = mkFunTys extra_arg_tys' res_ty
 	      subst   	     = boxySubMatchType arg_qtvs fun_res_ty res_ty'
@@ -686,15 +688,14 @@ tcIdApp fun_name n_args arg_checker res_ty
 	; 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 <- addErrCtxtM (checkFunResCtxt fun_name res_ty fun_res_ty'') $
-		   tcSubExp fun_res_ty'' res_ty''
+	; co_fn <- tcFunResTy fun_name 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 fun_id qtvs qtys'' tv_theta_prs
 	; co_fn' <- wrapFunResCoercion fun_arg_tys' co_fn
-	; return (HsCoerce co_fn' fun', args') }
+	; return (mkHsCoerce co_fn' fun', args') }
 \end{code}
 
 Note [Silly type synonyms in smart-app]
@@ -737,12 +738,11 @@ tcId orig fun_name res_ty
 	; let res_subst   = zipTopTvSubst qtvs qtv_tys
 	      fun_tau' = substTy res_subst fun_tau
 
-	; co_fn <- addErrCtxtM (checkFunResCtxt fun_name res_ty fun_tau') $
-		   tcSubExp fun_tau' res_ty
+	; co_fn <- tcFunResTy fun_name fun_tau' res_ty
 
 	-- And pack up the results
 	; fun' <- instFun fun_id qtvs qtv_tys tv_theta_prs 
-	; return (HsCoerce co_fn fun') }
+	; return (mkHsCoerce co_fn fun') }
 
 -- 	Note [Push result type in]
 --
@@ -893,29 +893,6 @@ tcArg :: LHsExpr Name				-- The function (for error messages)
        -> TcM (LHsExpr TcId)			-- Resulting argument
 tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no) $
 			      tcPolyExprNC arg ty
-
-
-----------------
--- If an error happens we try to figure out whether the
--- function has been given too many or too few arguments,
--- and say so.
-checkFunResCtxt fun expected_res_ty actual_res_ty tidy_env
-  = zonkTcType expected_res_ty	  `thenM` \ exp_ty' ->
-    zonkTcType actual_res_ty	  `thenM` \ act_ty' ->
-    let
-      (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
-      (env2, act_ty'') = tidyOpenType env1     act_ty'
-      (exp_args, _)    = tcSplitFunTys exp_ty''
-      (act_args, _)    = tcSplitFunTys act_ty''
-
-      len_act_args     = length act_args
-      len_exp_args     = length exp_args
-
-      message | len_exp_args < len_act_args = wrongArgsCtxt "too few"  fun
-              | len_exp_args > len_act_args = wrongArgsCtxt "too many" fun
-	      | otherwise		    = empty
-    in
-    returnM (env2, message)
 \end{code}
 
 
@@ -991,8 +968,14 @@ thBrackId orig id_name id ps_var lie_var
 	       -- solve this, and it's probably unimportant, so I'm
 	       -- just going to flag an error for now
    
+	; id_ty' <- zapToMonotype id_ty
+		-- The id_ty might have an OpenTypeKind, but we
+		-- can't instantiate the Lift class at that kind,
+		-- 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
+	{ lift <- newMethodFromName orig id_ty' DsMeta.liftName
 		   -- Put the 'lift' constraint into the right LIE
 	   
 		   -- Update the pending splices
@@ -1183,11 +1166,6 @@ missingFields con fields
 callCtxt fun args
   = ptext SLIT("In the call") <+> parens (ppr (foldl mkHsApp fun args))
 
-wrongArgsCtxt too_many_or_few fun
-  = ptext SLIT("Probable cause:") <+> quotes (ppr fun)
-	<+> ptext SLIT("is applied to") <+> text too_many_or_few 
-	<+> ptext SLIT("arguments")
-
 #ifdef GHCI
 polySpliceErr :: Id -> SDoc
 polySpliceErr id