X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FCheck.lhs;h=359035f70524ca320258ad85156ddad3c2a24dc7;hb=90dc9026b091be5cca5da4c6cbd3713ecc493361;hp=0b2dc088597c648fcf55a8eeba3aeda39738743c;hpb=00913724d2ba7128e2db401a19f7b131fb182618;p=ghc-hetmet.git diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index 0b2dc08..359035f 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -1,36 +1,31 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1997-1998 % % Author: Juan J. Quintela -\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 TcType +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 +146,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 @@ -429,6 +424,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 @@ -438,12 +434,12 @@ mb_neg (Just _) v = -v get_unused_cons :: [Pat Id] -> [DataCon] get_unused_cons 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 @@ -623,7 +619,7 @@ simplify_pat pat@(WildPat gt) = pat simplify_pat (VarPat id) = WildPat (idType id) simplify_pat (VarPatOut id _) = WildPat (idType id) -- Ignore the bindings simplify_pat (ParPat p) = unLoc (simplify_lpat p) -simplify_pat (LazyPat p) = WildPat (hsPatType p) -- For overlap and exhaustiveness checking +simplify_pat (LazyPat p) = WildPat (hsLPatType p) -- For overlap and exhaustiveness checking -- purposes, a ~pat is like a wildcard simplify_pat (BangPat p) = unLoc (simplify_lpat p) simplify_pat (AsPat id p) = unLoc (simplify_lpat p) @@ -675,6 +671,8 @@ simplify_pat (DictPat dicts methods) num_of_d_and_ms = length dicts + length methods dict_and_method_pats = map VarPat (dicts ++ methods) +simplify_pat (CoPat co pat ty) = simplify_pat pat + ----------------- simplify_con con (PrefixCon ps) = PrefixCon (map simplify_lpat ps) simplify_con con (InfixCon p1 p2) = PrefixCon [simplify_lpat p1, simplify_lpat p2] @@ -685,7 +683,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)]