import HsSyn
-import TcHsSyn ( TypecheckedPat )
-import DsHsSyn ( outPatType )
-import CoreSyn
-
-import DsUtils ( EquationInfo(..),
- MatchResult(..),
- EqnSet,
- CanItFail(..),
- tidyLitPat
+import TcHsSyn ( TypecheckedPat, outPatType )
+import TcType ( tcTyConAppTyCon, tcTyConAppArgs )
+import DsUtils ( EquationInfo(..), MatchResult(..), EqnSet,
+ CanItFail(..), tidyLitPat, tidyNPat,
)
import Id ( idType )
-import DataCon ( DataCon, isTupleCon, isUnboxedTupleCon, dataConArgTys,
+import DataCon ( DataCon, dataConTyCon, dataConArgTys,
dataConSourceArity, dataConFieldLabels )
-import Name ( Name, mkLocalName, getOccName, isDataSymOcc, getName, mkSrcVarOcc )
-import Type ( Type, splitAlgTyConApp, mkTyVarTys,
- isUnboxedType, splitTyConApp_maybe
- )
-import TysPrim ( intPrimTy,
- charPrimTy,
- floatPrimTy,
- doublePrimTy,
- addrPrimTy,
- wordPrimTy
- )
-import TysWiredIn ( nilDataCon, consDataCon,
- mkTupleTy, tupleCon,
- mkUnboxedTupleTy, unboxedTupleCon,
- mkListTy,
- charTy, charDataCon,
- intTy, intDataCon,
- floatTy, floatDataCon,
- doubleTy, doubleDataCon,
- addrTy, addrDataCon,
- wordTy, wordDataCon,
- stringTy
- )
-import Unique ( unboundKey )
-import TyCon ( tyConDataCons )
+import Name ( Name, mkLocalName, getOccName, isDataSymOcc, getName, mkVarOcc )
+import TcType ( mkTyVarTys )
+import TysPrim ( charPrimTy )
+import TysWiredIn
+import PrelNames ( unboundKey )
+import TyCon ( tyConDataCons, tupleTyConBoxity, isTupleTyCon )
+import BasicTypes ( Boxity(..) )
import SrcLoc ( noSrcLoc )
import UniqSet
+import Util ( takeList, splitAtList )
import Outputable
#include "HsVersions.h"
untidy b (ConOpPatIn pat1 name fixity pat2) =
pars b (ConOpPatIn (untidy_pars pat1) name fixity (untidy_pars pat2))
untidy _ (ListPatIn pats) = ListPatIn (map untidy_no_pars pats)
+untidy _ (PArrPatIn pats) =
+ panic "Check.untidy: Shouldn't get a parallel array here!"
untidy _ (TuplePatIn pats boxed) = TuplePatIn (map untidy_no_pars pats) boxed
-untidy _ (SigPatIn pat ty) = panic "Check.untidy: SigPatIn"
-untidy _ (LazyPatIn pat) = panic "Check.untidy: LazyPatIn"
-untidy _ (AsPatIn name pat) = panic "Check.untidy: AsPatIn"
-untidy _ (NPlusKPatIn name lit) = panic "Check.untidy: NPlusKPatIn"
-untidy _ (NegPatIn ipat) = panic "Check.untidy: NegPatIn"
-untidy _ (ParPatIn pat) = panic "Check.untidy: ParPatIn"
-untidy _ (RecPatIn name fields) = panic "Check.untidy: RecPatIn"
+untidy _ pat = pprPanic "Check.untidy: SigPatIn" (ppr pat)
pars :: NeedPars -> WarningPat -> WarningPat
pars True p = ParPatIn p
check' [] = ([([],[])],emptyUniqSet)
check' [EqnInfo n ctx ps (MatchResult CanFail _)]
- | all_vars ps = ([(take (length ps) (repeat new_wild_pat),[])], unitUniqSet n)
+ | all_vars ps = ([(takeList ps (repeat new_wild_pat),[])], unitUniqSet n)
check' qs@((EqnInfo n ctx ps (MatchResult CanFail _)):rs)
| all_vars ps = (pats, addOneToUniqSet indexs n)
process_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
process_literals used_lits qs
- | length default_eqns == 0 = ([make_row_vars used_lits (head qs)]++pats,indexs)
- | otherwise = (pats_default,indexs_default)
+ | null default_eqns = ([make_row_vars used_lits (head qs)]++pats,indexs)
+ | otherwise = (pats_default,indexs_default)
where
(pats,indexs) = process_explicit_literals used_lits qs
default_eqns = (map remove_var (filter is_var qs))
split_by_constructor :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
-split_by_constructor qs | length unused_cons /= 0 = need_default_case used_cons unused_cons qs
- | otherwise = no_need_default_case used_cons qs
+split_by_constructor qs
+ | not (null unused_cons) = need_default_case used_cons unused_cons qs
+ | otherwise = no_need_default_case used_cons qs
where
used_cons = get_used_cons qs
unused_cons = get_unused_cons used_cons
need_default_case :: [TypecheckedPat] -> [DataCon] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
need_default_case used_cons unused_cons qs
- | length default_eqns == 0 = (pats_default_no_eqns,indexs)
- | otherwise = (pats_default,indexs_default)
+ | null default_eqns = (pats_default_no_eqns,indexs)
+ | otherwise = (pats_default,indexs_default)
where
(pats,indexs) = no_need_default_case used_cons qs
default_eqns = (map remove_var (filter is_var qs))
make_row_vars :: [HsLit] -> EquationInfo -> ExhaustivePat
make_row_vars used_lits (EqnInfo _ _ pats _ ) =
- (VarPatIn new_var:take (length (tail pats)) (repeat new_wild_pat),[(new_var,used_lits)])
+ (VarPatIn new_var:takeList (tail pats) (repeat new_wild_pat),[(new_var,used_lits)])
where new_var = hash_x
hash_x = mkLocalName unboundKey {- doesn't matter much -}
- (mkSrcVarOcc SLIT("#x"))
+ (mkVarOcc SLIT("#x"))
noSrcLoc
make_row_vars_for_constructor :: EquationInfo -> [WarningPat]
-make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = take (length (tail pats)) (repeat new_wild_pat)
+make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = takeList (tail pats) (repeat new_wild_pat)
compare_cons :: TypecheckedPat -> TypecheckedPat -> Bool
compare_cons (ConPat id1 _ _ _ _) (ConPat id2 _ _ _ _) = id1 == id2
get_unused_cons used_cons = unused_cons
where
(ConPat _ ty _ _ _) = head used_cons
- Just (ty_con,_) = splitTyConApp_maybe ty
+ ty_con = tcTyConAppTyCon ty -- Newtype observable
all_cons = tyConDataCons ty_con
used_cons_as_id = map (\ (ConPat d _ _ _ _) -> d) used_cons
unused_cons = uniqSetToList
(mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id)
-
all_vars :: [TypecheckedPat] -> Bool
all_vars [] = True
all_vars (WildPat _:ps) = all_vars ps
where name = getName id
fixity = panic "Check.make_con: Guessing fixity"
-make_con (ConPat id _ _ _ pats) (ps,constraints)
- | isTupleCon id = (TuplePatIn pats_con True : rest_pats, constraints)
- | isUnboxedTupleCon id = (TuplePatIn pats_con False : rest_pats, constraints)
- | otherwise = (ConPatIn name pats_con : rest_pats, constraints)
- where num_args = length pats
- name = getName id
- pats_con = take num_args ps
- rest_pats = drop num_args ps
+make_con (ConPat id _ _ _ pats) (ps, constraints)
+ | isTupleTyCon tc = (TuplePatIn pats_con (tupleTyConBoxity tc) : rest_pats, constraints)
+ | otherwise = (ConPatIn name pats_con : rest_pats, constraints)
+ where name = getName id
+ (pats_con, rest_pats) = splitAtList pats ps
+ tc = dataConTyCon id
+
+-- reconstruct parallel array pattern
+--
+-- * 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
+--
+make_con (ConPat id _ _ _ pats) (ps, constraints)
+ | isPArrFakeCon id = (PArrPatIn patsCon : restPats, constraints)
+ | otherwise = (ConPatIn name patsCon : restPats, constraints)
+ where
+ name = getName id
+ (patsCon, restPats) = splitAtList pats ps
+ tc = dataConTyCon id
make_whole_con :: DataCon -> WarningPat
fixity = panic "Check.make_whole_con: Guessing fixity"
name = getName con
arity = dataConSourceArity con
- pats = take arity (repeat new_wild_pat)
+ pats = replicate arity new_wild_pat
new_wild_pat :: WarningPat
simplify_pat pat@(WildPat gt) = pat
simplify_pat (VarPat id) = WildPat (idType id)
-simplify_pat (LazyPat p) = simplify_pat p
-simplify_pat (AsPat id p) = simplify_pat p
+simplify_pat (LazyPat p) = simplify_pat p
+simplify_pat (AsPat id p) = simplify_pat p
+simplify_pat (SigPat p ty fn) = simplify_pat p -- I'm not sure this is right
simplify_pat (ConPat id ty tvs dicts ps) = ConPat id ty tvs dicts (map simplify_pat ps)
(map simplify_pat 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 ty ps)
+ = ConPat (parrFakeCon arity) (mkPArrTy ty) [] [] (map simplify_pat ps)
+ where
+ arity = length ps
-simplify_pat (TuplePat ps True) = ConPat (tupleCon arity)
- (mkTupleTy arity (map outPatType ps)) [] []
- (map simplify_pat ps)
- where
- arity = length ps
-
-simplify_pat (TuplePat ps False)
- = ConPat (unboxedTupleCon arity)
- (mkUnboxedTupleTy arity (map outPatType ps)) [] []
+simplify_pat (TuplePat ps boxity)
+ = ConPat (tupleCon boxity arity)
+ (mkTupleTy boxity arity (map outPatType ps)) [] []
(map simplify_pat ps)
where
arity = length ps
where
all_wild_pats = map WildPat con_arg_tys
- -- identical to machinations in Match.tidy1:
- (_, inst_tys, _) = splitAlgTyConApp ty
- con_arg_tys = dataConArgTys dc (inst_tys ++ mkTyVarTys ex_tvs)
+ -- Identical to machinations in Match.tidy1:
+ inst_tys = tcTyConAppArgs ty -- Newtype is observable
+ con_arg_tys = dataConArgTys dc (inst_tys ++ mkTyVarTys ex_tvs)
simplify_pat (RecPat dc ty ex_tvs dicts idps)
= ConPat dc ty ex_tvs dicts pats
| nm == n = (nm,p):xs
| otherwise = x : insertNm nm p xs
-simplify_pat pat@(LitPat lit lit_ty) = tidyLitPat lit lit_ty pat
-simplify_pat pat@(NPat lit lit_ty hsexpr) = tidyLitPat lit lit_ty pat
+simplify_pat pat@(LitPat lit lit_ty) = tidyLitPat lit pat
+
+-- unpack string patterns fully, so we can see when they overlap with
+-- each other, or even explicit lists of Chars.
+simplify_pat pat@(NPat (HsString s) _ _) =
+ foldr (\c pat -> ConPat consDataCon stringTy [] [] [mk_char_lit c,pat])
+ (ConPat nilDataCon stringTy [] [] []) (_UNPK_INT_ s)
+ where
+ mk_char_lit c = ConPat charDataCon charTy [] []
+ [LitPat (HsCharPrim c) charPrimTy]
+
+simplify_pat pat@(NPat lit lit_ty hsexpr) = tidyNPat lit lit_ty pat
simplify_pat (NPlusKPat id hslit ty hsexpr1 hsexpr2) =
WildPat ty
simplify_pat (DictPat dicts methods) =
case num_of_d_and_ms of
- 0 -> simplify_pat (TuplePat [] True)
+ 0 -> simplify_pat (TuplePat [] Boxed)
1 -> simplify_pat (head dict_and_method_pats)
- _ -> simplify_pat (TuplePat dict_and_method_pats True)
+ _ -> simplify_pat (TuplePat dict_and_method_pats Boxed)
where
num_of_d_and_ms = length dicts + length methods
dict_and_method_pats = map VarPat (dicts ++ methods)
-
\end{code}
projects / ghc-hetmet.git / blobdiff