X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcArrows.lhs;h=5a76356a9b189c57403ceb5fa646435e5ebb3b2c;hb=5f553f0c0508cb09b75f78e6c2ac1baa4c01b6aa;hp=eda193a095d892fdd12608720224d09ccbbc2a4f;hpb=98688c6e8fd33f31c51218cf93cbf03fe3a5e73d;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcArrows.lhs b/ghc/compiler/typecheck/TcArrows.lhs
index eda193a..5a76356 100644
--- a/ghc/compiler/typecheck/TcArrows.lhs
+++ b/ghc/compiler/typecheck/TcArrows.lhs
@@ -11,7 +11,7 @@ module TcArrows ( tcProc ) where
 import {-# SOURCE #-}	TcExpr( tcCheckRho )
 
 import HsSyn
-import TcHsSyn	( TcCmdTop, TcExpr, TcPat, mkHsLet )
+import TcHsSyn	(  mkHsLet )
 
 import TcMatches ( TcStmtCtxt(..), tcMatchPats, matchCtxt, tcStmts,
 		  TcMatchCtxt(..), tcMatchesCase )
@@ -24,12 +24,12 @@ import TcSimplify ( tcSimplifyCheck )
 import TcUnify	( Expected(..), checkSigTyVarsWrt, zapExpectedTo )
 import TcRnMonad
 import Inst	( tcSyntaxName )
+import Name	( Name )
 import TysWiredIn ( boolTy, pairTyCon )
 import VarSet 
-import Type	( Kind,
-		  mkArrowKinds, liftedTypeKind, openTypeKind, tyVarsOfTypes )
-import RnHsSyn	( RenamedHsExpr, RenamedPat, RenamedHsCmdTop )
+import Type	( Kind, mkArrowKinds, liftedTypeKind, openTypeKind, tyVarsOfTypes )
 
+import SrcLoc	( Located(..) )
 import Outputable
 import Util	( lengthAtLeast )
 
@@ -42,9 +42,9 @@ import Util	( lengthAtLeast )
 %************************************************************************
 
 \begin{code}
-tcProc :: RenamedPat -> RenamedHsCmdTop		-- proc pat -> expr
+tcProc :: InPat Name -> LHsCmdTop Name		-- proc pat -> expr
        -> Expected TcRhoType			-- Expected type of whole proc expression
-       -> TcM (TcPat, TcCmdTop)
+       -> TcM (OutPat TcId, LHsCmdTop TcId)
 
 tcProc pat cmd exp_ty
  = do	{ arr_ty <- newTyVarTy arrowTyConKind
@@ -75,60 +75,65 @@ mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2]
 
 ---------------------------------------
 tcCmdTop :: CmdEnv 
-        -> RenamedHsCmdTop 
-        -> (CmdStack, TcTauType)	-- Expected result type; always a monotype
+         -> LHsCmdTop Name
+         -> (CmdStack, TcTauType)	-- Expected result type; always a monotype
 					-- We know exactly how many cmd args are expected,
 					-- albeit perhaps not their types; so we can pass 
 					-- in a CmdStack
-        -> TcM TcCmdTop
+        -> TcM (LHsCmdTop TcId)
 
-tcCmdTop env (HsCmdTop cmd _ _ names) (cmd_stk, res_ty)
-  = do	{ cmd'   <- tcCmd env cmd (cmd_stk, res_ty)
+tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) (cmd_stk, res_ty)
+  = addSrcSpan loc $
+    do	{ cmd'   <- tcCmd env cmd (cmd_stk, res_ty)
 	; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names
-	; return (HsCmdTop cmd' cmd_stk res_ty names') }
+	; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') }
 
 
 ----------------------------------------
-tcCmd :: CmdEnv -> RenamedHsExpr -> (CmdStack, TcTauType) -> TcM TcExpr
+tcCmd :: CmdEnv -> LHsExpr Name -> (CmdStack, TcTauType) -> TcM (LHsExpr TcId)
 	-- The main recursive function
+tcCmd env (L loc expr) res_ty
+  = addSrcSpan loc $ do
+	{ expr' <- tc_cmd env expr res_ty
+	; return (L loc expr') }
 
-tcCmd env (HsPar cmd) res_ty
+tc_cmd env (HsPar cmd) res_ty
   = do	{ cmd' <- tcCmd env cmd res_ty
 	; return (HsPar cmd') }
 
-tcCmd env (HsLet binds body) res_ty
-  = tcBindsAndThen HsLet binds $
-    tcCmd env body res_ty
+tc_cmd env (HsLet binds (L body_loc body)) res_ty
+  = tcBindsAndThen glue binds	$
+    addSrcSpan body_loc 	$
+    tc_cmd env body res_ty
+  where
+    glue binds expr = HsLet [binds] (L body_loc expr)
 
-tcCmd env in_cmd@(HsCase scrut matches src_loc) (stk, res_ty)
-  = addSrcLoc src_loc			$
-    addErrCtxt (cmdCtxt in_cmd)		$
+tc_cmd env in_cmd@(HsCase scrut matches) (stk, res_ty)
+  = addErrCtxt (cmdCtxt in_cmd)		$
     tcMatchesCase match_ctxt matches (Check res_ty)
 					`thenM`	\ (scrut_ty, matches') ->
     addErrCtxt (caseScrutCtxt scrut)	(
       tcCheckRho scrut scrut_ty
     )					`thenM`	\ scrut' ->
-    returnM (HsCase scrut' matches' src_loc)
+    returnM (HsCase scrut' matches')
   where
     match_ctxt = MC { mc_what = CaseAlt,
                       mc_body = mc_body }
     mc_body body (Check res_ty') = tcCmd env body (stk, res_ty')
 
-tcCmd env (HsIf pred b1 b2 src_loc) res_ty
-  = addSrcLoc src_loc	$ 
-    do 	{ pred' <- tcCheckRho pred boolTy
+tc_cmd env (HsIf pred b1 b2) res_ty
+  = do 	{ pred' <- tcCheckRho pred boolTy
 	; b1'   <- tcCmd env b1 res_ty
 	; b2'   <- tcCmd env b2 res_ty
-	; return (HsIf pred' b1' b2' src_loc)
+	; return (HsIf pred' b1' b2')
     }
 
 -------------------------------------------
 -- 		Arrow application
 --     	    (f -< a)   or   (f =< a)
 
-tcCmd env cmd@(HsArrApp fun arg _ ho_app lr src_loc) (cmd_stk, res_ty)
-  = addSrcLoc src_loc		$ 
-    addErrCtxt (cmdCtxt cmd)	$
+tc_cmd env cmd@(HsArrApp fun arg _ ho_app lr) (cmd_stk, res_ty)
+  = addErrCtxt (cmdCtxt cmd)	$
     do  { arg_ty <- newTyVarTy openTypeKind
 	; let fun_ty = mkCmdArrTy env arg_ty res_ty
 
@@ -138,7 +143,7 @@ tcCmd env cmd@(HsArrApp fun arg _ ho_app lr src_loc) (cmd_stk, res_ty)
 
 	; arg' <- tcCheckRho arg arg_ty
 
-	; return (HsArrApp fun' arg' fun_ty ho_app lr src_loc) }
+	; return (HsArrApp fun' arg' fun_ty ho_app lr) }
   where
 	-- Before type-checking f, remove the "arrow binders" from the 
 	-- environment in the (-<) case.  
@@ -151,7 +156,7 @@ tcCmd env cmd@(HsArrApp fun arg _ ho_app lr src_loc) (cmd_stk, res_ty)
 -------------------------------------------
 -- 		Command application
 
-tcCmd env cmd@(HsApp fun arg) (cmd_stk, res_ty)
+tc_cmd env cmd@(HsApp fun arg) (cmd_stk, res_ty)
   = addErrCtxt (cmdCtxt cmd)	$
     do  { arg_ty <- newTyVarTy openTypeKind
 
@@ -164,9 +169,8 @@ tcCmd env cmd@(HsApp fun arg) (cmd_stk, res_ty)
 -------------------------------------------
 -- 		Lambda
 
-tcCmd env cmd@(HsLam match@(Match pats maybe_rhs_sig grhss)) (cmd_stk, res_ty)
-  = addSrcLoc (getMatchLoc match)		$
-    addErrCtxt (matchCtxt match_ctxt match)	$
+tc_cmd env cmd@(HsLam (L mtch_loc match@(Match pats maybe_rhs_sig grhss))) (cmd_stk, res_ty)
+  = addErrCtxt (matchCtxt match_ctxt match)	$
 
     do	{ 	-- Check the cmd stack is big enough
 	; checkTc (lengthAtLeast cmd_stk n_pats)
@@ -174,10 +178,11 @@ tcCmd env cmd@(HsLam match@(Match pats maybe_rhs_sig grhss)) (cmd_stk, res_ty)
 	; let pats_w_tys = zip pats (map Check cmd_stk)
 
 		-- Check the patterns, and the GRHSs inside
-	; (pats', grhss', ex_binds) <- tcMatchPats pats_w_tys (Check res_ty) $
+	; (pats', grhss', ex_binds) <- addSrcSpan mtch_loc			$
+				       tcMatchPats pats_w_tys (Check res_ty)	$
 				       tc_grhss grhss
 
-	; return (HsLam (Match pats' Nothing (glueBindsOnGRHSs ex_binds grhss')))
+	; return (HsLam (L mtch_loc (Match pats' Nothing (glueBindsOnGRHSs ex_binds grhss'))))
 	}
 
   where
@@ -187,25 +192,24 @@ tcCmd env cmd@(HsLam match@(Match pats maybe_rhs_sig grhss)) (cmd_stk, res_ty)
 
     tc_grhss (GRHSs grhss binds _)
 	= tcBindsAndThen glueBindsOnGRHSs binds 	$
-	  do { grhss' <- mappM tc_grhs grhss
-	     ; return (GRHSs grhss' EmptyBinds res_ty) }
+	  do { grhss' <- mappM (wrapLocM tc_grhs) grhss
+	     ; return (GRHSs grhss' [] res_ty) }
 
     stmt_ctxt = SC { sc_what = PatGuard match_ctxt, 
 		     sc_rhs  = tcCheckRho, 
 		     sc_body = \ body -> tcCmd env body (stk', res_ty),
 		     sc_ty   = res_ty }	-- ToDo: Is this right?
-    tc_grhs (GRHS guarded locn)
-	= addSrcLoc locn	$
-	  do { guarded' <- tcStmts stmt_ctxt guarded	
-	     ; return (GRHS guarded' locn) }
+    tc_grhs (GRHS guarded)
+	= do { guarded' <- tcStmts stmt_ctxt guarded	
+	     ; return (GRHS guarded') }
 
 -------------------------------------------
 -- 		Do notation
 
-tcCmd env cmd@(HsDo do_or_lc stmts _ ty src_loc) (cmd_stk, res_ty)
+tc_cmd env cmd@(HsDo do_or_lc stmts _ ty) (cmd_stk, res_ty)
   = do 	{ checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd)
 	; stmts' <- tcStmts stmt_ctxt stmts 
-	; return (HsDo do_or_lc stmts' [] res_ty src_loc) }
+	; return (HsDo do_or_lc stmts' [] res_ty) }
 	-- The 'methods' needed for the HsDo are in the enclosing HsCmd
 	-- hence the empty list here
   where
@@ -228,10 +232,9 @@ tcCmd env cmd@(HsDo do_or_lc stmts _ ty src_loc) (cmd_stk, res_ty)
 --	----------------------------------------------
 --	G |-a  (| e |) c  :  [t1 .. tn] t
 
-tcCmd env cmd@(HsArrForm expr fixity cmd_args src_loc) (cmd_stk, res_ty)	
-  = addSrcLoc src_loc		$ 
-    addErrCtxt (cmdCtxt cmd)	$
-    do	{ cmds_w_tys <- mapM new_cmd_ty (cmd_args `zip` [1..])
+tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)	
+  = addErrCtxt (cmdCtxt cmd)	$
+    do	{ cmds_w_tys <- zipWithM new_cmd_ty cmd_args [1..]
 	; w_tv       <- newSigTyVar liftedTypeKind
 	; let w_ty = mkTyVarTy w_tv
 
@@ -256,14 +259,14 @@ tcCmd env cmd@(HsArrForm expr fixity cmd_args src_loc) (cmd_stk, res_ty)
 		-- the s1..sm and check each cmd
 	; cmds' <- mapM (tc_cmd w_tv') cmds_w_tys
 
-	; returnM (HsArrForm (TyLam [w_tv'] (mkHsLet inst_binds expr')) fixity cmds' src_loc)
+	; returnM (HsArrForm (mkHsTyLam [w_tv'] (mkHsLet inst_binds expr')) fixity cmds')
 	}
   where
  	-- Make the types	
 	--	b, ((e,s1) .. sm), s
-    new_cmd_ty :: (RenamedHsCmdTop, Int)
-	       -> TcM (RenamedHsCmdTop, Int, TcType, TcType, TcType)
-    new_cmd_ty (cmd,i)
+    new_cmd_ty :: LHsCmdTop Name -> Int
+	       -> TcM (LHsCmdTop Name, Int, TcType, TcType, TcType)
+    new_cmd_ty cmd i
 	  = do	{ b_ty   <- newTyVarTy arrowTyConKind
 		; tup_ty <- newTyVarTy liftedTypeKind
 			-- We actually make a type variable for the tuple
@@ -302,7 +305,7 @@ tcCmd env cmd@(HsArrForm expr fixity cmd_args src_loc) (cmd_stk, res_ty)
 --		Base case for illegal commands
 -- This is where expressions that aren't commands get rejected
 
-tcCmd env cmd _
+tc_cmd env cmd _
   = failWithTc (vcat [ptext SLIT("The expression"), nest 2 (ppr cmd), 
 		      ptext SLIT("was found where an arrow command was expected")])
 \end{code}
@@ -316,8 +319,8 @@ tcCmd env cmd _
 
 
 \begin{code}
-glueBindsOnCmd EmptyBinds cmd				  = cmd
-glueBindsOnCmd binds      (HsCmdTop cmd stk res_ty names) = HsCmdTop (HsLet binds cmd) stk res_ty names
+glueBindsOnCmd binds (L loc (HsCmdTop cmd stk res_ty names))
+  = L loc (HsCmdTop (L loc (HsLet [binds] cmd)) stk res_ty names)
 	-- Existential bindings become local bindings in the command