X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FCheck.lhs;h=9f3bad0b0d92f44fd18410fe28e25f116e9f6079;hp=85b8f9ddd9959da94b65f6cbf457b47164bb0754;hb=940524aec90652b5ef81789c9a453c57c0e42cc9;hpb=171d4582f4b9a8e0f11f8738079accbb22bafdcb

diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs
index 85b8f9d..9f3bad0 100644
--- a/compiler/deSugar/Check.lhs
+++ b/compiler/deSugar/Check.lhs
@@ -1,36 +1,30 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
 %
 % Author: Juan J. Quintela    <quintela@krilin.dc.fi.udc.es>
-\section{Module @Check@ in @deSugar@}
 
 \begin{code}
-
-
 module Check ( check , ExhaustivePat ) where
 
+#include "HsVersions.h"
 
 import HsSyn		
-import TcHsSyn		( hsLPatType, mkVanillaTuplePat )
-import TcType		( tcTyConAppTyCon )
-import DsUtils		( EquationInfo(..), MatchResult(..), 
-			  CanItFail(..), firstPat )
-import MatchLit		( tidyLitPat, tidyNPat )
-import Id		( Id, idType )
-import DataCon		( DataCon, dataConTyCon, dataConOrigArgTys, dataConFieldLabels )
-import Name             ( Name, mkInternalName, getOccName, isDataSymOcc,
-			  getName, mkVarOccFS )
+import TcHsSyn
+import DsUtils
+import MatchLit
+import Id
+import DataCon
+import Name
 import TysWiredIn
-import PrelNames	( unboundKey )
-import TyCon            ( tyConDataCons, tupleTyConBoxity, isTupleTyCon )
-import BasicTypes	( Boxity(..) )
-import SrcLoc		( noSrcLoc, Located(..), unLoc, noLoc )
+import PrelNames
+import TyCon
+import BasicTypes
+import SrcLoc
 import UniqSet
-import Util             ( takeList, splitAtList, notNull )
+import Util
 import Outputable
 import FastString
-
-#include "HsVersions.h"
 \end{code}
 
 This module performs checks about if one list of equations are:
@@ -151,7 +145,7 @@ untidy b (L loc p) = L loc (untidy' b p)
 
 untidy_con (PrefixCon pats) = PrefixCon (map untidy_pars pats) 
 untidy_con (InfixCon p1 p2) = InfixCon  (untidy_pars p1) (untidy_pars p2)
-untidy_con (RecCon bs)      = RecCon    [(f,untidy_pars p) | (f,p) <- bs]
+untidy_con (RecCon bs)      = RecCon    [ HsRecField f (untidy_pars p) d | HsRecField f p d <- bs ]
 
 pars :: NeedPars -> WarningPat -> Pat Name
 pars True p = ParPat p
@@ -254,7 +248,7 @@ must be one Variable to be complete.
 
 process_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
 process_literals used_lits qs 
-  | null default_eqns  = ([make_row_vars used_lits (head qs)] ++ pats,indexs)
+  | null default_eqns  = ASSERT( not (null qs) ) ([make_row_vars used_lits (head qs)] ++ pats,indexs)
   | otherwise          = (pats_default,indexs_default)
      where
        (pats,indexs)   = process_explicit_literals used_lits qs
@@ -336,7 +330,7 @@ need_default_case used_cons unused_cons qs
        (pats',indexs') = check' default_eqns 
        pats_default    = [(make_whole_con c:ps,constraints) | 
                           c <- unused_cons, (ps,constraints) <- pats'] ++ pats
-       new_wilds       = make_row_vars_for_constructor (head qs)
+       new_wilds       = ASSERT( not (null qs) ) make_row_vars_for_constructor (head qs)
        pats_default_no_eqns =  [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats
        indexs_default  = unionUniqSets indexs' indexs
 
@@ -384,7 +378,7 @@ make_row_vars used_lits (_, EqnInfo { eqn_pats = pats})
 
 hash_x = mkInternalName unboundKey {- doesn't matter much -}
 		     (mkVarOccFS FSLIT("#x"))
-		     noSrcLoc
+		     noSrcSpan
 
 make_row_vars_for_constructor :: (EqnNo, EquationInfo) -> [WarningPat]
 make_row_vars_for_constructor (_, EqnInfo { eqn_pats = pats}) 
@@ -429,6 +423,7 @@ get_lit :: Pat id -> Maybe HsLit
 get_lit (LitPat lit)			 = Just lit
 get_lit (NPat (HsIntegral i   _) mb _ _) = Just (HsIntPrim   (mb_neg mb i))
 get_lit (NPat (HsFractional f _) mb _ _) = Just (HsFloatPrim (mb_neg mb f))
+get_lit (NPat (HsIsString s   _)  _ _ _) = Just (HsStringPrim s)
 get_lit other_pat			 = Nothing
 
 mb_neg :: Num a => Maybe b -> a -> a
@@ -436,7 +431,7 @@ mb_neg Nothing  v = v
 mb_neg (Just _) v = -v
 
 get_unused_cons :: [Pat Id] -> [DataCon]
-get_unused_cons used_cons = unused_cons
+get_unused_cons used_cons = ASSERT( not (null used_cons) ) unused_cons
      where
        (ConPatOut { pat_con = l_con, pat_ty = ty }) = head used_cons
        ty_con 	       = dataConTyCon (unLoc l_con)	-- Newtype observable
@@ -687,7 +682,7 @@ simplify_con con (RecCon fs)
   where
      -- pad out all the missing fields with WildPats.
     field_pats = map (\ f -> (f, nlWildPat)) (dataConFieldLabels con)
-    all_pats = foldr (\ (id,p) acc -> insertNm (getName (unLoc id)) p acc)
+    all_pats = foldr (\(HsRecField id p _) acc -> insertNm (getName (unLoc id)) p acc)
 		     field_pats fs
        
     insertNm nm p [] = [(nm,p)]