%
+% (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}
-
+{-# 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:
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.
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)]
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}
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 [(f,untidy_pars p) | (f,p) <- 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
(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
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
[(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
(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
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})
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' [] = []
-- 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 negate mb i))
+get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) = Just (HsFloatPrim (mb_neg negateFractionalLit mb 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
+mb_neg :: (a -> a) -> Maybe b -> a -> a
+mb_neg _ Nothing v = v
+mb_neg negate (Just _) v = negate 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
+ used_set :: UniqSet DataCon
+ used_set = mkUniqSet [d | ConPatOut{ pat_con = L _ d} <- used_cons]
(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)
+ 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
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)
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
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
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)@
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"
| 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
+
+--------------
+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)
- 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)]
projects / ghc-hetmet.git / blobdiff