X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsArrows.lhs;h=4d9295d6aef56d7f8844aa683fa31ae3533ecc07;hp=111e0bccd04882dfddf0e3a054d2cd851d8b4213;hb=49c98d143c382a1341e1046f5ca00819a25691ba;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1

diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs
index 111e0bc..4d9295d 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		( hsPatType )
+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,24 @@ import TcHsSyn		( hsPatType )
 
 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
 \end{code}
 
 \begin{code}
@@ -262,7 +255,7 @@ dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids))
     matchSimply (Var var) ProcExpr pat (mkTupleExpr env_ids) fail_expr
 					`thenDs` \ match_code ->
     let
-	pat_ty = hsPatType pat
+	pat_ty = hsLPatType pat
 	proc_code = do_map_arrow meth_ids pat_ty env_ty cmd_ty
 		(Lam var match_code)
 		core_cmd
@@ -511,10 +504,10 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_
     dsLookupDataCon leftDataConName	`thenDs` \ left_con ->
     dsLookupDataCon rightDataConName	`thenDs` \ right_con ->
     let
-	left_id = nlHsVar (dataConWrapId left_con)
-	right_id = nlHsVar (dataConWrapId right_con)
-	left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ TyApp left_id [ty1, ty2]) e
-	right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ TyApp right_id [ty1, ty2]) e
+	left_id  = HsVar (dataConWrapId left_con)
+	right_id = HsVar (dataConWrapId right_con)
+	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.
@@ -742,10 +735,10 @@ dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ c_ty)
 -- but that's likely to be defined in terms of first.
 
 dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _)
-  = dsfixCmd ids local_vars [] (hsPatType pat) cmd
+  = dsfixCmd ids local_vars [] (hsLPatType pat) cmd
 				`thenDs` \ (core_cmd, fv_cmd, env_ids1) ->
     let
-	pat_ty = hsPatType pat
+	pat_ty = hsLPatType pat
 	pat_vars = mkVarSet (collectPatBinders pat)
 	env_ids2 = varSetElems (mkVarSet out_ids `minusVarSet` pat_vars)
 	env_ty2 = mkTupleType env_ids2