X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=27b4cf15a150a23f6f796a5f711f6b334b3aa181;hp=4c0754de755b8dacb585277bda8d670467646757;hb=3f1b316d7035c55cd712cd39a9981339bcef2e8c;hpb=ad94d40948668032189ad22a0ad741ac1f645f50

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 4c0754d..27b4cf1 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -9,11 +9,10 @@
 -- 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/CodingStyle#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
@@ -289,33 +288,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
 
@@ -335,8 +322,8 @@ tcExpr (ExplicitTuple exprs boxity) 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), 
@@ -527,54 +514,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!"
@@ -1010,7 +1001,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 +1012,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 +1044,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 +1203,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}