X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=804fb478907be2e4cb00d90d34a9fd5707153773;hp=3cd04c44e5a5b26a14787a74a487bf0dc1a46cbb;hb=1d1c3c727617630beacacaf33022e1daba06a0bb;hpb=17b297d97d327620ed6bfab942f8992b2446f1bf

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 3cd04c4..804fb47 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -5,15 +5,14 @@
 \section[TcExpr]{Typecheck an expression}
 
 \begin{code}
-{-# OPTIONS_GHC -w #-}
+{-# 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/WorkingConventions#Warnings
+--     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, tcInferRho, tcSyntaxOp) where
 
 #include "HsVersions.h"
 
@@ -133,7 +132,7 @@ tcExpr (HsVar name)     res_ty = tcId (OccurrenceOf name) name res_ty
 
 tcExpr (HsLit lit)	res_ty = do { let lit_ty = hsLitType lit
 				    ; coi <- boxyUnify lit_ty res_ty
-				    ; return $ wrapExprCoI (HsLit lit) coi
+				    ; return $ mkHsWrapCoI coi (HsLit lit)
 				    }
 
 tcExpr (HsPar expr)     res_ty = do { expr' <- tcMonoExpr expr res_ty
@@ -154,19 +153,20 @@ tcExpr (HsOverLit lit) 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')) }
 
@@ -193,7 +193,7 @@ tcExpr in_expr@(ExprWithTySig expr sig_ty) 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
@@ -289,33 +289,21 @@ 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
-  = do 	{ elt_ty <- boxySplitListTy res_ty
+  = do 	{ (elt_ty, coi) <- boxySplitListTy res_ty
 	; exprs' <- mappM (tc_elt elt_ty) exprs
-	; return (ExplicitList elt_ty exprs') }
+	; return $ mkHsWrapCoI coi (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	{ (elt_ty, coi) <- boxySplitPArrTy res_ty
     	; exprs' <- mappM (tc_elt elt_ty) exprs	
 	; ifM (null exprs) (zapToMonotype elt_ty)
 		-- 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
 
@@ -331,12 +319,12 @@ tcExpr (ExplicitTuple exprs boxity) res_ty
 	; 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    <- 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), 
@@ -482,8 +470,9 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty
     let
 	result_ty     = substTy result_inst_env con1_res_ty
 	con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys
+	origin 	      = RecordUpdOrigin
     in
-    tcSubExp result_ty res_ty			`thenM` \ co_fn ->
+    tcSubExp origin result_ty res_ty		`thenM` \ co_fn ->
     tcRecordBinds con1 con1_arg_tys' rbinds	`thenM` \ rbinds' ->
 
 	-- STEP 5: Typecheck the expression to be updated
@@ -503,7 +492,7 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty
     let
 	theta' = substTheta scrut_inst_env (dataConStupidTheta con1)
     in
-    instStupidTheta RecordUpdOrigin theta'	`thenM_`
+    instStupidTheta origin theta'	`thenM_`
 
 	-- 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 
@@ -527,54 +516,58 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty
 
 \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!"
@@ -688,7 +681,7 @@ 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 <- 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
@@ -735,7 +728,7 @@ tcId orig fun_name res_ty
 	; 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 
@@ -1010,7 +1003,7 @@ thLocalId orig id id_ty th_bind_lvl
 
 --------------------------------------
 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:
@@ -1021,7 +1014,7 @@ 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_name; return id }
+    do	{ keepAliveTc id; return id }
 
   | otherwise
   = 	-- Nested identifiers, such as 'x' in
@@ -1053,11 +1046,9 @@ thBrackId orig id ps_var lie_var
 	   
 		   -- 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}
 
@@ -1214,9 +1205,3 @@ polySpliceErr 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}