X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcPat.lhs;h=c9b5d6e6503cb226a9af402ff3bba4af37e21245;hb=366e8db02ab7a5bb5316699bff397d06e47891b2;hp=b9099beb5589a14ca26fa59d6c182e075180d492;hpb=190f24892156953d73b55401d0467a6f1a88ce5d;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index b9099be..c9b5d6e 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -1,7 +1,9 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-\section[TcPat]{Typechecking patterns}
+
+TcPat: Typechecking patterns
 
 \begin{code}
 module TcPat ( tcLetPat, tcLamPat, tcLamPats, tcOverloadedLit,
@@ -10,58 +12,34 @@ module TcPat ( tcLetPat, tcLamPat, tcLamPats, tcOverloadedLit,
 #include "HsVersions.h"
 
 import {-# SOURCE #-}	TcExpr( tcSyntaxOp )
-import HsSyn		( Pat(..), LPat, HsConDetails(..), HsLit(..),
-			  HsOverLit(..), HsExpr(..), HsWrapper(..),
-			  mkCoPat, HsRecField(..), mkRecField,
-			  LHsBinds, emptyLHsBinds, isEmptyLHsBinds, 
-			  collectPatsBinders, nlHsLit,
-                          LHsDoc )
-import TcHsSyn		( TcId, hsLitType )
+
+import HsSyn
+import TcHsSyn
 import TcRnMonad
-import Inst		( InstOrigin(..), shortCutFracLit, shortCutIntLit, 
-			  newDictBndrs, instToId, instStupidTheta, isHsVar
-			)
-import Id		( Id, idType, mkLocalId )
-import Var		( CoVar, tyVarKind )
-import CoreFVs		( idFreeTyVars )
-import Name		( Name, mkSystemVarName )
-import TcSimplify	( tcSimplifyCheck, bindInstsOfLocalFuns )
-import TcEnv		( newLocalName, tcExtendIdEnv1, tcExtendTyVarEnv2,
-			  tcLookupClass, tcLookupDataCon, refineEnvironment,
-			  tcLookupField, tcMetaTy )
-import TcMType 		( newFlexiTyVarTy, arityErr, tcInstSkolTyVars, 
-			  newCoVars, zonkTcType, tcInstTyVars, newBoxyTyVar )
-import TcType		( TcType, TcTyVar, TcSigmaType, TcRhoType, BoxyType,
-			  SkolemInfo(PatSkol), 
-			  BoxySigmaType, BoxyRhoType, argTypeKind, typeKind,
-			  pprSkolTvBinding, isRigidTy, tcTyVarsOfTypes, 
-			  zipTopTvSubst, isSubArgTypeKind, isUnboxedTupleType,
-			  mkTyVarTys, mkClassPred, isOverloadedTy, substEqSpec,
-			  mkFunTy, mkFunTys, tidyOpenType, tidyOpenTypes,
-			  mkTyVarTy )
-import VarSet		( elemVarSet )
-import {- Kind parts of -} 
-       Type		( liftedTypeKind )
-import TcUnify		( boxySplitTyConApp, boxySplitListTy, unBox,
-			  zapToMonotype, boxyUnify, boxyUnifyList,
-			  checkSigTyVarsWrt, unifyType )
-import TcHsType		( UserTypeCtxt(..), tcPatSig )
-import TysWiredIn	( boolTy, parrTyCon, tupleTyCon )
-import TcGadt		( Refinement, emptyRefinement, gadtRefine, refineType )
-import Type		( Type, mkTyConApp, substTys, substTheta )
-import StaticFlags	( opt_IrrefutableTuples )
-import TyCon		( TyCon, FieldLabel, tyConFamInst_maybe,
-			  tyConFamilyCoercion_maybe, tyConTyVars )
-import DataCon		( DataCon, dataConTyCon, dataConFullSig, dataConName,
-			  dataConFieldLabels, dataConSourceArity, 
-			  dataConStupidTheta, dataConUnivTyVars )
-import PrelNames	( integralClassName, fromIntegerName, integerTyConName, 
-			  fromRationalName, rationalTyConName )
-import BasicTypes	( isBoxed )
-import SrcLoc		( Located(..), SrcSpan, noLoc )
-import ErrUtils		( Message )
-import Util		( zipEqual )
-import Maybes		( MaybeErr(..) )
+import Inst
+import Id
+import Var
+import CoreFVs
+import Name
+import TcSimplify
+import TcEnv
+import TcMType
+import TcType
+import VarSet
+import TcUnify
+import TcHsType
+import TysWiredIn
+import TcGadt
+import Type
+import StaticFlags
+import TyCon
+import DataCon
+import PrelNames
+import BasicTypes hiding (SuccessFlag(..))
+import SrcLoc
+import ErrUtils
+import Util
+import Maybes
 import Outputable
 import FastString
 \end{code}
@@ -191,18 +169,18 @@ tcPatBndr (PS { pat_ctxt = LamPat }) bndr_name pat_ty
 		-- 	f t = case t of { MkT g -> ... }
 		-- Here, the 'g' must get type (forall a. a->a) from the
 		-- MkT context
-	; return (mkLocalId bndr_name pat_ty') }
+	; return (Id.mkLocalId bndr_name pat_ty') }
 
 tcPatBndr (PS { pat_ctxt = LetPat lookup_sig }) bndr_name pat_ty
   | Just mono_ty <- lookup_sig bndr_name
   = do	{ mono_name <- newLocalName bndr_name
 	; boxyUnify mono_ty pat_ty
-	; return (mkLocalId mono_name mono_ty) }
+	; return (Id.mkLocalId mono_name mono_ty) }
 
   | otherwise
   = do	{ pat_ty' <- unBoxPatBndrType pat_ty bndr_name
 	; mono_name <- newLocalName bndr_name
-	; return (mkLocalId mono_name pat_ty') }
+	; return (Id.mkLocalId mono_name pat_ty') }
 
 
 -------------------
@@ -301,7 +279,9 @@ tc_lpat :: LPat Name
 tc_lpat (L span pat) pat_ty pstate thing_inside
   = setSrcSpan span		  $
     maybeAddErrCtxt (patCtxt pat) $
-    do	{ let (coercion, pat_ty') = refineType (pat_reft pstate) pat_ty
+    do	{ let mb_reft = refineType (pat_reft pstate) pat_ty
+	      pat_ty' = case mb_reft of { Just (_, ty') -> ty'; Nothing -> pat_ty }
+
 		-- Make sure the result type reflects the current refinement
 		-- We must do this here, so that it correctly ``sees'' all
 		-- the refinements to the left.  Example:
@@ -311,7 +291,10 @@ tc_lpat (L span pat) pat_ty pstate thing_inside
 		-- pattern had better see it.
 
 	; (pat', tvs, res) <- tc_pat pstate pat pat_ty' thing_inside
-	; return (mkCoPat coercion (L span pat') pat_ty, tvs, res) }
+	; let final_pat = case mb_reft of
+				Nothing     -> pat'
+				Just (co,_) -> CoPat (WpCo co) pat' pat_ty
+	; return (L span final_pat, tvs, res) }
 
 --------------------
 tc_pat	:: PatState
@@ -822,7 +805,8 @@ newLitInst orig lit res_ty	-- Make a LitInst
 	; res_tau <- zapToMonotype res_ty
 	; new_uniq <- newUnique
 	; let	lit_nm   = mkSystemVarName new_uniq FSLIT("lit")
-		lit_inst = LitInst lit_nm lit res_tau loc
+		lit_inst = LitInst {tci_name = lit_nm, tci_lit = lit, 
+				    tci_ty = res_tau, tci_loc = loc}
 	; extendLIE lit_inst
 	; return (HsVar (instToId lit_inst)) }
 \end{code}