X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FMatchLit.lhs;h=2cdab30bf8b162c0059b9182b1eab6385bdfb7b7;hb=90dc9026b091be5cca5da4c6cbd3713ecc493361;hp=3c10c1c985d4d81b87bf2d8ae1b9a7678908f920;hpb=37507b3a4342773030ef538599363a5aff8b666a;p=ghc-hetmet.git

diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs
index 3c10c1c..2cdab30 100644
--- a/compiler/deSugar/MatchLit.lhs
+++ b/compiler/deSugar/MatchLit.lhs
@@ -1,7 +1,9 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-\section[MatchLit]{Pattern-matching literal patterns}
+
+Pattern-matching literal patterns
 
 \begin{code}
 module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey,
@@ -17,24 +19,23 @@ import DsMonad
 import DsUtils
 
 import HsSyn
-import Id		( Id, idType )
+import Id
 import CoreSyn
-import TyCon		( tyConDataCons )
-import DataCon		( DataCon )
-import TcType		( tcSplitTyConApp, isIntegerTy, isIntTy, 
-			  isFloatTy, isDoubleTy, isStringTy )
-import Type		( Type )
-import PrelNames	( ratioTyConKey )
-import TysWiredIn	( stringTy, consDataCon, intDataCon, floatDataCon, doubleDataCon )
-import PrelNames	( eqStringName )
-import Unique		( hasKey )
-import Literal		( mkMachInt, Literal(..) )
-import SrcLoc		( noLoc )
-import Ratio 		( numerator, denominator )
-import SrcLoc		( Located(..), unLoc )
+import TyCon
+import DataCon
+import TcType
+import Type
+import PrelNames
+import TysWiredIn
+import PrelNames
+import Unique
+import Literal
+import SrcLoc
+import Ratio
+import SrcLoc
 import Outputable
-import Util		( mapAndUnzip )
-import FastString	( lengthFS, unpackFS )
+import Util
+import FastString
 \end{code}
 
 %************************************************************************
@@ -86,6 +87,7 @@ dsOverLit :: HsOverLit Id -> DsM CoreExpr
 -- (an expression for) the literal value itself
 dsOverLit (HsIntegral   _ lit) = dsExpr lit
 dsOverLit (HsFractional _ lit) = dsExpr lit
+dsOverLit (HsIsString   _ lit) = dsExpr lit
 \end{code}
 
 \begin{code}
@@ -108,6 +110,8 @@ hsOverLitKey (HsIntegral i _) False   = MachInt i
 hsOverLitKey (HsIntegral i _) True    = MachInt (-i)
 hsOverLitKey (HsFractional r _) False = MachFloat r
 hsOverLitKey (HsFractional r _) True  = MachFloat (-r)
+hsOverLitKey (HsIsString s _)  False  = MachStr s
+-- negated string should never happen
 \end{code}
 
 %************************************************************************
@@ -139,6 +143,7 @@ tidyNPat over_lit mb_neg eq lit_ty
   | isIntTy    lit_ty = mk_con_pat intDataCon    (HsIntPrim int_val)
   | isFloatTy  lit_ty = mk_con_pat floatDataCon  (HsFloatPrim  rat_val)
   | isDoubleTy lit_ty = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
+--  | isStringTy lit_ty = mk_con_pat stringDataCon (HsStringPrim str_val)
   | otherwise	      = NPat over_lit mb_neg eq lit_ty
   where
     mk_con_pat :: DataCon -> HsLit -> Pat Id
@@ -157,6 +162,11 @@ tidyNPat over_lit mb_neg eq lit_ty
     rat_val = case neg_lit of
 		HsIntegral   i _ -> fromInteger i
 		HsFractional f _ -> f
+	
+    str_val :: FastString
+    str_val = case neg_lit of
+		HsIsString   s _ -> s
+		_                -> error "tidyNPat"
 \end{code}
 
 
@@ -256,7 +266,7 @@ matchNPlusKPats all_vars@(var:vars) ty (eqn1:eqns)
 	; lit_expr    <- dsOverLit lit
 	; let pred_expr   = mkApps ge_expr [Var var, lit_expr]
 	      minusk_expr = mkApps minus_expr [Var var, lit_expr]
-	      (wraps, eqns') = mapAndUnzip (shift n1) eqns
+	      (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
 	; match_result <- match vars ty eqns'
 	; return  (mkGuardedMatchResult pred_expr 		$
 		   mkCoLetMatchResult (NonRec n1 minusk_expr)	$