Store a SrcSpan instead of a SrcLoc inside a Name

[ghc-hetmet.git] / compiler / deSugar / Check.lhs

diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs
index 7562083..9f3bad0 100644 (file)
--- 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,14 +431,14 @@ 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_ty = ty }) = head used_cons
-       ty_con                = tcTyConAppTyCon ty              -- Newtype observable
-       all_cons                      = tyConDataCons ty_con
-       used_cons_as_id               = map (\ (ConPatOut{ pat_con = L _ d}) -> d) used_cons
-       unused_cons                   = uniqSetToList
-                (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id) 
+       (ConPatOut { pat_con = l_con, pat_ty = ty }) = head used_cons
+       ty_con         = dataConTyCon (unLoc l_con)     -- Newtype observable
+       all_cons        = tyConDataCons ty_con
+       used_cons_as_id = map (\ (ConPatOut{ pat_con = L _ d}) -> d) used_cons
+       unused_cons     = uniqSetToList
+                        (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id) 
 
 all_vars :: [Pat Id] -> Bool
 all_vars []             = True
@@ -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)]