import MatchLit ( tidyLitPat, tidyNPat )
import Id ( Id, idType )
import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConFieldLabels )
-import Name ( Name, mkInternalName, getOccName, isDataSymOcc, getName, mkVarOcc )
+import Name ( Name, mkInternalName, getOccName, isDataSymOcc,
+ getName, mkVarOccFS )
import TysWiredIn
import PrelNames ( unboundKey )
import TyCon ( tyConDataCons, tupleTyConBoxity, isTupleTyCon )
\begin{code}
-check' :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)
+check' :: [(EqnNo, EquationInfo)]
+ -> ([ExhaustivePat], -- Pattern scheme that might not be matched at all
+ EqnSet) -- Eqns that are used (others are overlapped)
+
check' [] = ([([],[])],emptyUniqSet)
-check' [(n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult CanFail _ })]
- | all_vars ps = ([(takeList ps (repeat nlWildPat),[])], unitUniqSet n)
+check' ((n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult can_fail _ }) : rs)
+ | first_eqn_all_vars && case can_fail of { CantFail -> True; CanFail -> False }
+ = ([], unitUniqSet n) -- One eqn, which can't fail
+
+ | first_eqn_all_vars && null rs -- One eqn, but it can fail
+ = ([(takeList ps (repeat nlWildPat),[])], unitUniqSet n)
-check' ((n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult CanFail _}) : rs)
- | all_vars ps = (pats, addOneToUniqSet indexs n)
+ | first_eqn_all_vars -- Several eqns, first can fail
+ = (pats, addOneToUniqSet indexs n)
where
+ first_eqn_all_vars = all_vars ps
(pats,indexs) = check' rs
-check' qs@((n, EqnInfo { eqn_pats = ps }) : _)
- | all_vars ps = ([], unitUniqSet n)
+check' qs
| literals = split_by_literals qs
| constructors = split_by_constructor qs
| only_vars = first_column_only_vars qs
remove_first_column :: Pat Id -- Constructor
-> [(EqnNo, EquationInfo)]
-> [(EqnNo, EquationInfo)]
-remove_first_column (ConPatOut con _ _ _ (PrefixCon con_pats) _) qs
+remove_first_column (ConPatOut (L _ con) _ _ _ (PrefixCon con_pats) _) qs
= ASSERT2( okGroup qs, pprGroup qs )
[(n, shift_var eqn) | q@(n, eqn) <- qs, is_var_con con (firstPatN q)]
where
new_var = hash_x
hash_x = mkInternalName unboundKey {- doesn't matter much -}
- (mkVarOcc FSLIT("#x"))
+ (mkVarOccFS FSLIT("#x"))
noSrcLoc
make_row_vars_for_constructor :: (EqnNo, EquationInfo) -> [WarningPat]
= takeList (tail pats) (repeat nlWildPat)
compare_cons :: Pat Id -> Pat Id -> Bool
-compare_cons (ConPatOut id1 _ _ _ _ _) (ConPatOut id2 _ _ _ _ _) = id1 == id2
+compare_cons (ConPatOut (L _ id1) _ _ _ _ _) (ConPatOut (L _ id2) _ _ _ _ _) = id1 == id2
remove_dups :: [Pat Id] -> [Pat Id]
remove_dups [] = []
get_used_lits' :: [(EqnNo, EquationInfo)] -> [HsLit]
get_used_lits' [] = []
get_used_lits' (q:qs)
- | LitPat lit <- first_pat = lit : get_used_lits qs
- | NPatOut lit _ _ <- first_pat = lit : get_used_lits qs
- | otherwise = get_used_lits qs
- where
- first_pat = firstPatN q
+ | Just lit <- get_lit (firstPatN q) = lit : get_used_lits' qs
+ | otherwise = get_used_lits qs
+
+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
+
+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
(ConPatOut _ _ _ _ _ ty) = head used_cons
ty_con = tcTyConAppTyCon ty -- Newtype observable
all_cons = tyConDataCons ty_con
- used_cons_as_id = map (\ (ConPatOut d _ _ _ _ _) -> d) used_cons
+ used_cons_as_id = map (\ (ConPatOut (L _ d) _ _ _ _ _) -> d) used_cons
unused_cons = uniqSetToList
(mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id)
is_lit :: Pat Id -> Bool
is_lit (LitPat _) = True
-is_lit (NPatOut _ _ _) = True
+is_lit (NPat _ _ _ _) = True
is_lit _ = False
is_var :: Pat Id -> Bool
is_var_con :: DataCon -> Pat Id -> Bool
is_var_con con (WildPat _) = True
-is_var_con con (ConPatOut id _ _ _ _ _) | id == con = True
+is_var_con con (ConPatOut (L _ id) _ _ _ _ _) | id == con = True
is_var_con con _ = False
is_var_lit :: HsLit -> Pat Id -> Bool
-is_var_lit lit (WildPat _) = True
-is_var_lit lit (LitPat lit') | lit == lit' = True
-is_var_lit lit (NPatOut lit' _ _) | lit == lit' = True
-is_var_lit lit _ = False
+is_var_lit lit (WildPat _) = True
+is_var_lit lit pat
+ | Just lit' <- get_lit pat = lit == lit'
+ | otherwise = False
\end{code}
The difference beteewn @make_con@ and @make_whole_con@ is that
make_list _ _ = panic "Check.make_list: Invalid argument"
make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat
-make_con (ConPatOut id _ _ _ _ _) (lp:lq:ps, constraints)
+make_con (ConPatOut (L _ id) _ _ _ _ _) (lp:lq:ps, constraints)
| return_list id q = (noLoc (make_list lp q) : ps, constraints)
| isInfixCon id = (nlInfixConPat (getName id) lp lq : ps, constraints)
where q = unLoc lq
-make_con (ConPatOut id _ _ _ (PrefixCon pats) _) (ps, constraints)
+make_con (ConPatOut (L _ id) _ _ _ (PrefixCon pats) _) (ps, constraints)
| isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc)) : rest_pats, constraints)
| isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType) : rest_pats, constraints)
| otherwise = (nlConPat name pats_con : rest_pats, constraints)
-- reconstruct parallel array pattern
--
--- * don't check for the type only; we need to make sure that we are really
+-- * don't check for the type only; we need to make sure that we are really
-- dealing with one of the fake constructors and not with the real
-- representation
\begin{code}
simplify_eqn :: EquationInfo -> EquationInfo
-simplify_eqn eqn = eqn { eqn_pats = map simplify_pat (eqn_pats eqn) }
+simplify_eqn eqn = eqn { eqn_pats = map simplify_pat (eqn_pats eqn),
+ eqn_rhs = simplify_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
+ | 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 (ConPatOut _ _ _ _ ps ty) = any has_nplusk_lpat (hsConArgs ps)
+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
+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 (AsPat id p) = unLoc (simplify_lpat p)
simplify_pat (SigPatOut p _) = unLoc (simplify_lpat p) -- I'm not sure this is right
-simplify_pat (ConPatOut id tvs dicts binds ps ty)
- = ConPatOut id tvs dicts binds (simplify_con id ps) ty
+simplify_pat (ConPatOut (L loc id) tvs dicts binds ps ty)
+ = ConPatOut (L loc id) tvs dicts binds (simplify_con id ps) ty
simplify_pat (ListPat ps ty) =
unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty)
where
arity = length ps
-simplify_pat pat@(LitPat lit) = unLoc (tidyLitPat lit (noLoc pat))
-
-- unpack string patterns fully, so we can see when they overlap with
-- each other, or even explicit lists of Chars.
-simplify_pat pat@(NPatOut (HsString s) _ _) =
+simplify_pat pat@(LitPat (HsString s)) =
foldr (\c pat -> mk_simple_con_pat consDataCon (PrefixCon [mk_char_lit c,noLoc pat]) stringTy)
(mk_simple_con_pat nilDataCon (PrefixCon []) stringTy) (unpackFS s)
where
mk_char_lit c = noLoc (mk_simple_con_pat charDataCon (PrefixCon [nlLitPat (HsCharPrim c)]) charTy)
-simplify_pat pat@(NPatOut lit lit_ty hsexpr) = unLoc (tidyNPat lit lit_ty (noLoc pat))
+simplify_pat pat@(LitPat lit) = unLoc (tidyLitPat lit (noLoc pat))
+
+simplify_pat pat@(NPat lit mb_neg _ lit_ty) = unLoc (tidyNPat lit mb_neg lit_ty (noLoc pat))
-simplify_pat (NPlusKPatOut id hslit hsexpr1 hsexpr2)
+simplify_pat (NPlusKPat id hslit hsexpr1 hsexpr2)
= WildPat (idType (unLoc id))
simplify_pat (DictPat dicts methods)
num_of_d_and_ms = length dicts + length methods
dict_and_method_pats = map VarPat (dicts ++ methods)
-mk_simple_con_pat con args ty = ConPatOut con [] [] emptyLHsBinds args ty
+mk_simple_con_pat con args ty = ConPatOut (noLoc con) [] [] emptyLHsBinds args ty
-----------------
simplify_con con (PrefixCon ps) = PrefixCon (map simplify_lpat ps)
projects / ghc-hetmet.git / blobdiff