X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=98942a499614e23dd46e3c3993c442ad4375d9dc;hb=084a2fc52452bc2aba0511dd191923d677088d02;hp=93d3fe93caa49942e9c8f44f064828d949db97e1;hpb=4a343629ebe5be2c5b27e84c031e38abd81122fa;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 93d3fe9..98942a4 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -12,7 +12,9 @@
 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 -- for details
 
-module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, tcInferRho, tcInferRhoNC, tcSyntaxOp, addExprErrCtxt ) where
+module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, 
+                tcInferRho, tcInferRhoNC, tcSyntaxOp, 
+                addExprErrCtxt ) where
 
 #include "HsVersions.h"
 
@@ -259,7 +261,7 @@ tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty
 		<+> ptext (sLit "takes one argument")
     tc_args arg2_ty' qtvs qtys [arg1_ty, arg2_ty] 
 	= do { boxyUnify arg2_ty' (substTyWith qtvs qtys arg2_ty)
-	     ; arg1' <- tcArg lop 2 arg1 qtvs qtys arg1_ty 
+	     ; arg1' <- tcArg lop 1 arg1 qtvs qtys arg1_ty
 	     ; qtys' <- mapM refineBox qtys	-- c.f. tcArgs 
 	     ; return (qtys', arg1') }
     tc_args _ _ _ _ = panic "tcExpr SectionL"
@@ -280,6 +282,33 @@ tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty
 	     ; qtys' <- mapM refineBox qtys	-- c.f. tcArgs 
 	     ; return (qtys', arg2') }
     tc_args arg1_ty' _ _ _ = panic "tcExpr SectionR"
+
+-- 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 in_expr@(ExplicitTuple tup_args boxity) res_ty
+  = do { let kind = case boxity of { Boxed   -> liftedTypeKind
+                                   ; Unboxed -> argTypeKind }
+             arity = length tup_args
+             tup_tc = tupleTyCon boxity arity
+             mk_tup_res_ty arg_tys 
+                 = mkFunTys [ty | (ty, Missing _) <- arg_tys `zip` tup_args]
+                            (mkTyConApp tup_tc arg_tys)
+
+       ; checkWiredInTyCon tup_tc       -- Ensure instances are available
+       ; tvs <- newBoxyTyVars (replicate arity kind)
+       ; let arg_tys1 = map mkTyVarTy tvs
+       ; arg_tys2 <- preSubType tvs (mkVarSet tvs) (mk_tup_res_ty arg_tys1) res_ty
+       
+       ; let go (Missing _,    arg_ty) = return (Missing arg_ty)
+             go (Present expr, arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
+			                    ; return (Present expr') }
+       ; tup_args' <- mapM go (tup_args `zip` arg_tys2)
+       
+       ; arg_tys3 <- mapM refineBox arg_tys2
+       ; co_fn <- tcSubExp TupleOrigin (mk_tup_res_ty arg_tys3) res_ty
+       ; return (mkHsWrap co_fn (ExplicitTuple tup_args' boxity)) }
 \end{code}
 
 \begin{code}
@@ -344,23 +373,6 @@ tcExpr in_expr@(ExplicitPArr _ exprs) res_ty	-- maybe empty
   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	{ let kind = case boxity of { Boxed   -> liftedTypeKind
-				    ; Unboxed -> argTypeKind }
-	; tvs <- newBoxyTyVars [kind | 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', coi) <- tcProc pat cmd res_ty
 	; return $ mkHsWrapCoI coi (HsProc pat' cmd') }
@@ -880,9 +892,10 @@ tcId orig fun_name res_ty
 tcSyntaxOp :: InstOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
 -- Typecheck a syntax operator, checking that it has the specified type
 -- The operator is always a variable at this stage (i.e. renamer output)
+-- This version assumes ty is a monotype
 tcSyntaxOp orig (HsVar op) ty = tcId orig op ty
-tcSyntaxOp orig other 	   ty = pprPanic "tcSyntaxOp" (ppr other)
-
+tcSyntaxOp orig other 	   ty = pprPanic "tcSyntaxOp" (ppr other) 
+                        
 ---------------------------
 instFun :: InstOrigin
 	-> HsExpr TcId
@@ -1109,22 +1122,31 @@ lookupFun orig id_name
 
 #ifndef GHCI  /* GHCI and TH is off */
 --------------------------------------
--- thLocalId : Check for cross-stage lifting
-thLocalId orig id id_ty th_bind_lvl
+thLocalId :: InstOrigin -> Id -> TcType -> ThLevel -> TcM ()
+-- Check for cross-stage lifting
+thLocalId orig id id_ty bind_lvl
   = return ()
 
 #else	      /* GHCI and TH is on */
-thLocalId orig id id_ty th_bind_lvl 
+thLocalId orig id id_ty bind_lvl 
   = do	{ use_stage <- getStage	-- TH case
-	; case use_stage of
-	    Brack use_lvl ps_var lie_var | use_lvl > th_bind_lvl
-		  -> thBrackId orig id ps_var lie_var
-	    other -> do { checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage
-			; return id }
-	}
+	; let use_lvl = thLevel use_stage
+	; checkWellStaged (quotes (ppr id)) bind_lvl use_lvl
+	; traceTc (text "thLocalId" <+> ppr id <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl)
+	; when (use_lvl > bind_lvl) $
+          checkCrossStageLifting orig id id_ty bind_lvl use_stage }
 
 --------------------------------------
-thBrackId orig id ps_var lie_var
+checkCrossStageLifting :: InstOrigin -> Id -> TcType -> ThLevel -> ThStage -> TcM ()
+-- We are inside brackets, and (use_lvl > bind_lvl)
+-- Now we must check whether there's a cross-stage lift to do
+-- Examples   \x -> [| x |]  
+--            [| map |]
+
+checkCrossStageLifting _ _ _ _ Comp   = return ()
+checkCrossStageLifting _ _ _ _ Splice = return ()
+
+checkCrossStageLifting orig id id_ty bind_lvl (Brack _ ps_var lie_var) 
   | thTopLevelId id
   =	-- Top-level identifiers in this module,
 	-- (which have External Names)
@@ -1136,9 +1158,10 @@ 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; return id }
+    keepAliveTc id
 
-  | otherwise
+  | otherwise	-- bind_lvl = outerLevel presumably,
+		-- but the Id is not bound at top level
   = 	-- Nested identifiers, such as 'x' in
 	-- E.g. \x -> [| h x |]
 	-- We must behave as if the reference to x was
@@ -1148,8 +1171,7 @@ thBrackId orig id ps_var lie_var
 	-- If 'x' occurs many times we may get many identical
 	-- bindings of the same splice proxy, but that doesn't
 	-- matter, although it's a mite untidy.
-    do 	{ let id_ty = idType id
-	; checkTc (isTauTy id_ty) (polySpliceErr id)
+    do 	{ checkTc (isTauTy id_ty) (polySpliceErr id)
 	       -- If x is polymorphic, its occurrence sites might
 	       -- have different instantiations, so we can't use plain
 	       -- 'x' as the splice proxy name.  I don't know how to 
@@ -1173,7 +1195,7 @@ thBrackId orig id ps_var lie_var
 	; ps <- readMutVar ps_var
 	; writeMutVar ps_var ((idName id, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps)
 
-	; return id }
+	; return () }
 #endif /* GHCI */
 \end{code}