X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2FdeSugar%2FCheck.lhs;h=b8c61aa9ce8d1c218e319ea2ccc5bc9e26825e69;hb=b1ab4b8a607addc4d097588db5761313c996a41f;hp=0b2dc088597c648fcf55a8eeba3aeda39738743c;hpb=00913724d2ba7128e2db401a19f7b131fb182618;p=ghc-hetmet.git diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index 0b2dc08..b8c61aa 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 -\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 @@ -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 @@ -623,7 +618,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 +670,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 +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)]