X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsArrows.lhs;h=c44ed59243ba56dd12b3a362d1914503f13d458e;hb=a8427a4125e9b78e88a487eeabf018f1c6e8bc08;hp=d477eff08b26c25429f89439571725261bd592d7;hpb=15cb792d18b1094e98c035dca6ecec5dad516056;p=ghc-hetmet.git

diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs
index d477eff..c44ed59 100644
--- a/compiler/deSugar/DsArrows.lhs
+++ b/compiler/deSugar/DsArrows.lhs
@@ -1,23 +1,21 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-\section[DsArrows]{Desugaring arrow commands}
+
+Desugaring arrow commands
 
 \begin{code}
 module DsArrows ( dsProcExpr ) where
 
 #include "HsVersions.h"
 
-import Match		( matchSimply )
-import DsUtils		( mkErrorAppDs,
-			  mkCoreTupTy, mkCoreTup, selectSimpleMatchVarL,
-			  mkTupleCase, mkBigCoreTup, mkTupleType,
-			  mkTupleExpr, mkTupleSelector,
-			  dsSyntaxTable, lookupEvidence )
+import Match
+import DsUtils
 import DsMonad
 
 import HsSyn
-import TcHsSyn		( hsLPatType )
+import TcHsSyn
 
 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
 --     needs to see source types (newtypes etc), and sometimes not
@@ -26,29 +24,26 @@ import TcHsSyn		( hsLPatType )
 
 import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds )
 
-import TcType		( Type, tcSplitAppTy, mkFunTy )
-import Type		( mkTyConApp, funArgTy )
+import TcType
+import Type
 import CoreSyn
-import CoreFVs		( exprFreeVars )
-import CoreUtils	( mkIfThenElse, bindNonRec, exprType )
-
-import Id		( Id, idType )
-import Name		( Name )
-import PrelInfo		( pAT_ERROR_ID )
-import DataCon		( dataConWrapId )
-import TysWiredIn	( tupleCon )
-import BasicTypes	( Boxity(..) )
-import PrelNames	( eitherTyConName, leftDataConName, rightDataConName,
-			  arrAName, composeAName, firstAName,
-			  appAName, choiceAName, loopAName )
-import Util		( mapAccumL )
-import Outputable
-
-import HsUtils		( collectPatBinders, collectPatsBinders )
-import VarSet		( IdSet, mkVarSet, varSetElems,
-			  intersectVarSet, minusVarSet, extendVarSetList, 
-			  unionVarSet, unionVarSets, elemVarSet )
-import SrcLoc		( Located(..), unLoc, noLoc )
+import CoreFVs
+import CoreUtils
+
+import Id
+import Name
+import PrelInfo
+import DataCon
+import TysWiredIn
+import BasicTypes
+import PrelNames
+import Util
+
+import HsUtils
+import VarSet
+import SrcLoc
+
+import Data.List
 \end{code}
 
 \begin{code}
@@ -513,8 +508,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_
     let
 	left_id  = HsVar (dataConWrapId left_con)
 	right_id = HsVar (dataConWrapId right_con)
-	left_expr  ty1 ty2 e = noLoc $ HsApp (noLoc $ HsCoerce (mkCoTyApps [ty1, ty2]) left_id ) e
-	right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsCoerce (mkCoTyApps [ty1, ty2]) right_id) e
+	left_expr  ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
+	right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) right_id) e
 
 	-- Prefix each tuple with a distinct series of Left's and Right's,
 	-- in a balanced way, keeping track of the types.
@@ -593,6 +588,12 @@ dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args)
     returnDs (mkApps (App core_op (Type env_ty)) core_args,
 	      unionVarSets fv_sets)
 
+
+dsCmd ids local_vars env_ids stack res_ty (HsTick ix vars expr)
+  = dsLCmd ids local_vars env_ids stack res_ty expr `thenDs` \ (expr1,id_set) ->
+    mkTickBox ix vars expr1                    	    `thenDs` \ expr2 ->
+    return (expr2,id_set)
+
 --	A | ys |- c :: [ts] t	(ys <= xs)
 --	---------------------
 --	A | xs |- c :: [ts] t	---> arr_ts (\ (xs) -> (ys)) >>> c