X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FCheck.lhs;h=2402f9839bd909feea3e45a6148573279e9f34b0;hp=dbf2d72dc715272a5155fba59ec498265d942d2f;hb=3391a03562d4056de7b16cd0f632e6c43ae44cca;hpb=190f24892156953d73b55401d0467a6f1a88ce5d diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index dbf2d72..2402f98 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -1,36 +1,38 @@ % +% (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} - +{-# OPTIONS -fno-warn-incomplete-patterns #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details 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 Type +import SrcLoc import UniqSet -import Util ( takeList, splitAtList, notNull ) +import Util +import BasicTypes import Outputable import FastString - -#include "HsVersions.h" \end{code} This module performs checks about if one list of equations are: @@ -76,7 +78,7 @@ then all the constructors are equal: f (: x (: y [])) = .... f (: x xs) = ..... \end{verbatim} -(more about that in @simplify_eqns@) +(more about that in @tidy_eqns@) We would prefer to have a @WarningPat@ of type @String@, but Strings and the Pretty Printer are not friends. @@ -106,10 +108,12 @@ type EqnSet = UniqSet EqnNo check :: [EquationInfo] -> ([ExhaustivePat], [EquationInfo]) - -- Second result is the shadowed equations + -- Second result is the shadowed equations + -- if there are view patterns, just give up - don't know what the function is check qs = (untidy_warns, shadowed_eqns) where - (warns, used_nos) = check' ([1..] `zip` map simplify_eqn qs) + tidy_qs = map tidy_eqn qs + (warns, used_nos) = check' ([1..] `zip` tidy_qs) untidy_warns = map untidy_exhaustive warns shadowed_eqns = [eqn | (eqn,i) <- qs `zip` [1..], not (i `elementOfUniqSet` used_nos)] @@ -124,7 +128,7 @@ untidy_message :: (Name, [HsLit]) -> (Name, [HsLit]) untidy_message (string, lits) = (string, map untidy_lit lits) \end{code} -The function @untidy@ does the reverse work of the @simplify_pat@ funcion. +The function @untidy@ does the reverse work of the @tidy_pat@ funcion. \begin{code} @@ -139,19 +143,22 @@ untidy_pars p = untidy True p untidy :: NeedPars -> WarningPat -> WarningPat untidy b (L loc p) = L loc (untidy' b p) where - untidy' _ p@(WildPat _) = p - untidy' _ p@(VarPat name) = p - untidy' _ (LitPat lit) = LitPat (untidy_lit lit) - untidy' _ p@(ConPatIn name (PrefixCon [])) = p + untidy' _ p@(WildPat _) = p + untidy' _ p@(VarPat _) = p + untidy' _ (LitPat lit) = LitPat (untidy_lit lit) + untidy' _ p@(ConPatIn _ (PrefixCon [])) = p untidy' b (ConPatIn name ps) = pars b (L loc (ConPatIn name (untidy_con ps))) untidy' _ (ListPat pats ty) = ListPat (map untidy_no_pars pats) ty untidy' _ (TuplePat pats box ty) = TuplePat (map untidy_no_pars pats) box ty untidy' _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!" untidy' _ (SigPatIn _ _) = panic "Check.untidy: SigPat" +untidy_con :: HsConPatDetails Name -> HsConPatDetails Name 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 [ HsRecField f (untidy_pars p) d | HsRecField f p d <- bs ] +untidy_con (RecCon (HsRecFields flds dd)) + = RecCon (HsRecFields [ fld { hsRecFieldArg = untidy_pars (hsRecFieldArg fld) } + | fld <- flds ] dd) pars :: NeedPars -> WarningPat -> Pat Name pars True p = ParPat p @@ -210,17 +217,18 @@ check' ((n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult can_fail _ }) : rs) (pats,indexs) = check' rs check' qs - | literals = split_by_literals qs - | constructors = split_by_constructor qs - | only_vars = first_column_only_vars qs - | otherwise = pprPanic "Check.check': Not implemented :-(" (ppr first_pats) + | some_literals = split_by_literals qs + | some_constructors = split_by_constructor qs + | only_vars = first_column_only_vars qs + | otherwise = pprPanic "Check.check': Not implemented :-(" (ppr first_pats) + -- Shouldn't happen where -- Note: RecPats will have been simplified to ConPats -- at this stage. - first_pats = ASSERT2( okGroup qs, pprGroup qs ) map firstPatN qs - constructors = any is_con first_pats - literals = any is_lit first_pats - only_vars = all is_var first_pats + first_pats = ASSERT2( okGroup qs, pprGroup qs ) map firstPatN qs + some_constructors = any is_con first_pats + some_literals = any is_lit first_pats + only_vars = all is_var first_pats \end{code} Here begins the code to deal with literals, we need to split the matrix @@ -254,7 +262,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 @@ -284,7 +292,7 @@ remove_first_column_lit lit qs [(n, shift_pat eqn) | q@(n,eqn) <- qs, is_var_lit lit (firstPatN q)] where shift_pat eqn@(EqnInfo { eqn_pats = _:ps}) = eqn { eqn_pats = ps } - shift_pat eqn@(EqnInfo { eqn_pats = []}) = panic "Check.shift_var: no patterns" + shift_pat _ = panic "Check.shift_var: no patterns" \end{code} This function splits the equations @qs@ in groups that deal with the @@ -336,7 +344,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 @@ -382,9 +390,10 @@ make_row_vars used_lits (_, EqnInfo { eqn_pats = pats}) where new_var = hash_x +hash_x :: Name hash_x = mkInternalName unboundKey {- doesn't matter much -} - (mkVarOccFS FSLIT("#x")) - noSrcLoc + (mkVarOccFS (fsLit "#x")) + noSrcSpan make_row_vars_for_constructor :: (EqnNo, EquationInfo) -> [WarningPat] make_row_vars_for_constructor (_, EqnInfo { eqn_pats = pats}) @@ -402,8 +411,9 @@ get_used_cons :: [(EqnNo, EquationInfo)] -> [Pat Id] get_used_cons qs = remove_dups [pat | q <- qs, let pat = firstPatN q, isConPatOut pat] +isConPatOut :: Pat Id -> Bool isConPatOut (ConPatOut {}) = True -isConPatOut other = False +isConPatOut _ = False remove_dups' :: [HsLit] -> [HsLit] remove_dups' [] = [] @@ -426,24 +436,26 @@ get_lit :: Pat id -> Maybe HsLit -- Get a representative HsLit to stand for the OverLit -- It doesn't matter which one, because they will only be compared -- with other HsLits gotten in the same way -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 other_pat = Nothing +get_lit (LitPat lit) = Just lit +get_lit (NPat (OverLit { ol_val = HsIntegral i}) mb _) = Just (HsIntPrim (mb_neg mb i)) +get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) = Just (HsFloatPrim (mb_neg mb (fl_value f))) +get_lit (NPat (OverLit { ol_val = HsIsString s }) _ _) = Just (HsStringPrim s) +get_lit _ = Nothing mb_neg :: Num a => Maybe b -> a -> a 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 - 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) + used_set :: UniqSet DataCon + used_set = mkUniqSet [d | ConPatOut{ pat_con = L _ d} <- used_cons] + (ConPatOut { pat_ty = ty }) = head used_cons + Just (ty_con, inst_tys) = splitTyConApp_maybe ty + unused_cons = filterOut is_used (tyConDataCons ty_con) + is_used con = con `elementOfUniqSet` used_set + || dataConCannotMatch inst_tys con all_vars :: [Pat Id] -> Bool all_vars [] = True @@ -467,6 +479,8 @@ okGroup (e:es) = n_pats > 0 && and [length (eqnPats e) == n_pats | e <- es] n_pats = length (eqnPats e) -- Half-baked print +pprGroup :: [(EqnNo, EquationInfo)] -> SDoc +pprEqnInfo :: (EqnNo, EquationInfo) -> SDoc pprGroup es = vcat (map pprEqnInfo es) pprEqnInfo e = ppr (eqnPats e) @@ -480,7 +494,7 @@ is_con _ = False is_lit :: Pat Id -> Bool is_lit (LitPat _) = True -is_lit (NPat _ _ _ _) = True +is_lit (NPat _ _ _) = True is_lit _ = False is_var :: Pat Id -> Bool @@ -488,12 +502,12 @@ is_var (WildPat _) = True is_var _ = False is_var_con :: DataCon -> Pat Id -> Bool -is_var_con con (WildPat _) = True +is_var_con _ (WildPat _) = True is_var_con con (ConPatOut{ pat_con = L _ id }) | id == con = True -is_var_con con _ = False +is_var_con _ _ = False is_var_lit :: HsLit -> Pat Id -> Bool -is_var_lit lit (WildPat _) = True +is_var_lit _ (WildPat _) = True is_var_lit lit pat | Just lit' <- get_lit pat = lit == lit' | otherwise = False @@ -524,7 +538,7 @@ print the messsage, we are searching only for things like: @[1,2,3]@, not @x:xs@ .... In @reconstruct_pat@ we want to ``undo'' the work -that we have done in @simplify_pat@. +that we have done in @tidy_pat@. In particular: \begin{tabular}{lll} @((,) x y)@ & returns to be & @(x, y)@ @@ -537,16 +551,21 @@ contructors until the @[]@ to know that we need to use the second case, not the second. \fbox{\ ???\ } % \begin{code} +isInfixCon :: DataCon -> Bool isInfixCon con = isDataSymOcc (getOccName con) +is_nil :: Pat Name -> Bool is_nil (ConPatIn con (PrefixCon [])) = unLoc con == getName nilDataCon is_nil _ = False +is_list :: Pat Name -> Bool is_list (ListPat _ _) = True is_list _ = False +return_list :: DataCon -> Pat Name -> Bool return_list id q = id == consDataCon && (is_nil q || is_list q) +make_list :: LPat Name -> Pat Name -> Pat Name make_list p q | is_nil q = ListPat [p] placeHolderType make_list p (ListPat ps ty) = ListPat (p:ps) ty make_list _ _ = panic "Check.make_list: Invalid argument" @@ -577,113 +596,126 @@ make_whole_con con | isInfixCon con = nlInfixConPat name nlWildPat nlWildPat | otherwise = nlConPat name pats where name = getName con - pats = [nlWildPat | t <- dataConOrigArgTys con] + pats = [nlWildPat | _ <- dataConOrigArgTys con] \end{code} -This equation makes the same thing as @tidy@ in @Match.lhs@, the -difference is that here we can do all the tidy in one place and in the -@Match@ tidy it must be done one column each time due to bookkeeping -constraints. +------------------------------------------------------------------------ + Tidying equations +------------------------------------------------------------------------ -\begin{code} +tidy_eqn does more or less the same thing as @tidy@ in @Match.lhs@; +that is, it removes syntactic sugar, reducing the number of cases that +must be handled by the main checking algorithm. One difference is +that here we can do *all* the tidying at once (recursively), rather +than doing it incrementally. -simplify_eqn :: EquationInfo -> EquationInfo -simplify_eqn eqn = eqn { eqn_pats = map simplify_pat (eqn_pats eqn), - eqn_rhs = simplify_rhs (eqn_rhs eqn) } +\begin{code} +tidy_eqn :: EquationInfo -> EquationInfo +tidy_eqn eqn = eqn { eqn_pats = map tidy_pat (eqn_pats eqn), + eqn_rhs = tidy_rhs (eqn_rhs eqn) } where - -- Horrible hack. The simplify_pat stuff converts NPlusK pats to WildPats - -- which of course loses the info that they can fail to match. So we - -- stick in a CanFail as if it were a guard. - -- The Right Thing to do is for the whole system to treat NPlusK pats properly - simplify_rhs (MatchResult can_fail body) - | any has_nplusk_pat (eqn_pats eqn) = MatchResult CanFail body + -- Horrible hack. The tidy_pat stuff converts "might-fail" patterns to + -- WildPats which of course loses the info that they can fail to match. + -- So we stick in a CanFail as if it were a guard. + tidy_rhs (MatchResult can_fail body) + | any might_fail_pat (eqn_pats eqn) = MatchResult CanFail body | otherwise = MatchResult can_fail body -has_nplusk_lpat :: LPat Id -> Bool -has_nplusk_lpat (L _ p) = has_nplusk_pat p - -has_nplusk_pat :: Pat Id -> Bool -has_nplusk_pat (NPlusKPat _ _ _ _) = True -has_nplusk_pat (ParPat p) = has_nplusk_lpat p -has_nplusk_pat (AsPat _ p) = has_nplusk_lpat p -has_nplusk_pat (SigPatOut p _ ) = has_nplusk_lpat p -has_nplusk_pat (ListPat ps _) = any has_nplusk_lpat ps -has_nplusk_pat (TuplePat ps _ _) = any has_nplusk_lpat ps -has_nplusk_pat (PArrPat ps _) = any has_nplusk_lpat ps -has_nplusk_pat (LazyPat p) = False -- Why? -has_nplusk_pat (BangPat p) = has_nplusk_lpat p -- I think -has_nplusk_pat (ConPatOut { pat_args = ps }) = any has_nplusk_lpat (hsConArgs ps) -has_nplusk_pat p = False -- VarPat, VarPatOut, WildPat, LitPat, NPat, TypePat, DictPat - -simplify_lpat :: LPat Id -> LPat Id -simplify_lpat p = fmap simplify_pat p - -simplify_pat :: Pat Id -> Pat Id -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 (hsLPatType p) -- For overlap and exhaustiveness checking +-------------- +might_fail_pat :: Pat Id -> Bool +-- Returns True of patterns that might fail (i.e. fall through) in a way +-- that is not covered by the checking algorithm. Specifically: +-- NPlusKPat +-- ViewPat (if refutable) + +-- First the two special cases +might_fail_pat (NPlusKPat {}) = True +might_fail_pat (ViewPat _ p _) = not (isIrrefutableHsPat p) + +-- Now the recursive stuff +might_fail_pat (ParPat p) = might_fail_lpat p +might_fail_pat (AsPat _ p) = might_fail_lpat p +might_fail_pat (SigPatOut p _ ) = might_fail_lpat p +might_fail_pat (ListPat ps _) = any might_fail_lpat ps +might_fail_pat (TuplePat ps _ _) = any might_fail_lpat ps +might_fail_pat (PArrPat ps _) = any might_fail_lpat ps +might_fail_pat (BangPat p) = might_fail_lpat p +might_fail_pat (ConPatOut { pat_args = ps }) = any might_fail_lpat (hsConPatArgs ps) + +-- Finally the ones that are sure to succeed, or which are covered by the checking algorithm +might_fail_pat (LazyPat _) = False -- Always succeeds +might_fail_pat _ = False -- VarPat, WildPat, LitPat, NPat, TypePat + +-------------- +might_fail_lpat :: LPat Id -> Bool +might_fail_lpat (L _ p) = might_fail_pat p + +-------------- +tidy_lpat :: LPat Id -> LPat Id +tidy_lpat p = fmap tidy_pat p + +-------------- +tidy_pat :: Pat Id -> Pat Id +tidy_pat pat@(WildPat _) = pat +tidy_pat (VarPat id) = WildPat (idType id) +tidy_pat (ParPat p) = tidy_pat (unLoc p) +tidy_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) -simplify_pat (SigPatOut p _) = unLoc (simplify_lpat p) -- I'm not sure this is right - -simplify_pat pat@(ConPatOut { pat_con = L loc id, pat_args = ps }) - = pat { pat_args = simplify_con id ps } - -simplify_pat (ListPat ps ty) = - unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty) +tidy_pat (BangPat p) = tidy_pat (unLoc p) +tidy_pat (AsPat _ p) = tidy_pat (unLoc p) +tidy_pat (SigPatOut p _) = tidy_pat (unLoc p) +tidy_pat (CoPat _ pat _) = tidy_pat pat + +-- These two are might_fail patterns, so we map them to +-- WildPats. The might_fail_pat stuff arranges that the +-- guard says "this equation might fall through". +tidy_pat (NPlusKPat id _ _ _) = WildPat (idType (unLoc id)) +tidy_pat (ViewPat _ _ ty) = WildPat ty + +tidy_pat pat@(ConPatOut { pat_con = L _ id, pat_args = ps }) + = pat { pat_args = tidy_con id ps } + +tidy_pat (ListPat ps ty) + = unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty) (mkNilPat list_ty) - (map simplify_lpat ps) - where list_ty = mkListTy ty + (map tidy_lpat ps) + where list_ty = mkListTy ty -- introduce fake parallel array constructors to be able to handle parallel -- arrays with the existing machinery for constructor pattern -- -simplify_pat (PArrPat ps ty) +tidy_pat (PArrPat ps ty) = unLoc $ mkPrefixConPat (parrFakeCon (length ps)) - (map simplify_lpat ps) + (map tidy_lpat ps) (mkPArrTy ty) -simplify_pat (TuplePat ps boxity ty) +tidy_pat (TuplePat ps boxity ty) = unLoc $ mkPrefixConPat (tupleCon boxity arity) - (map simplify_lpat ps) ty + (map tidy_lpat ps) ty where arity = length ps --- unpack string patterns fully, so we can see when they overlap with --- each other, or even explicit lists of Chars. -simplify_pat pat@(LitPat (HsString s)) = - unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mk_char_lit c, pat] stringTy) - (mkPrefixConPat nilDataCon [] stringTy) (unpackFS s) - where - mk_char_lit c = mkPrefixConPat charDataCon [nlLitPat (HsCharPrim c)] charTy - -simplify_pat (LitPat lit) = tidyLitPat lit -simplify_pat (NPat lit mb_neg eq lit_ty) = tidyNPat lit mb_neg eq lit_ty - -simplify_pat (NPlusKPat id hslit hsexpr1 hsexpr2) - = WildPat (idType (unLoc id)) - -simplify_pat (DictPat dicts methods) - = case num_of_d_and_ms of - 0 -> simplify_pat (TuplePat [] Boxed unitTy) - 1 -> simplify_pat (head dict_and_method_pats) - _ -> simplify_pat (mkVanillaTuplePat (map noLoc dict_and_method_pats) Boxed) - where - num_of_d_and_ms = length dicts + length methods - dict_and_method_pats = map VarPat (dicts ++ methods) +tidy_pat (NPat lit mb_neg eq) = tidyNPat tidy_lit_pat lit mb_neg eq +tidy_pat (LitPat lit) = tidy_lit_pat lit -simplify_pat (CoPat co pat ty) = simplify_pat pat +tidy_lit_pat :: HsLit -> Pat Id +-- Unpack string patterns fully, so we can see when they +-- overlap with each other, or even explicit lists of Chars. +tidy_lit_pat lit + | HsString s <- lit + = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy) + (mkPrefixConPat nilDataCon [] stringTy) (unpackFS s) + | otherwise + = tidyLitPat lit ----------------- -simplify_con con (PrefixCon ps) = PrefixCon (map simplify_lpat ps) -simplify_con con (InfixCon p1 p2) = PrefixCon [simplify_lpat p1, simplify_lpat p2] -simplify_con con (RecCon fs) - | null fs = PrefixCon [nlWildPat | t <- dataConOrigArgTys con] +tidy_con :: DataCon -> HsConPatDetails Id -> HsConPatDetails Id +tidy_con _ (PrefixCon ps) = PrefixCon (map tidy_lpat ps) +tidy_con _ (InfixCon p1 p2) = PrefixCon [tidy_lpat p1, tidy_lpat p2] +tidy_con con (RecCon (HsRecFields fs _)) + | null fs = PrefixCon [nlWildPat | _ <- dataConOrigArgTys con] -- Special case for null patterns; maybe not a record at all - | otherwise = PrefixCon (map (simplify_lpat.snd) all_pats) + | otherwise = PrefixCon (map (tidy_lpat.snd) all_pats) where -- pad out all the missing fields with WildPats. field_pats = map (\ f -> (f, nlWildPat)) (dataConFieldLabels con)