import HsSyn
import TcHsSyn ( TypecheckedPat )
import DsHsSyn ( outPatType )
-import CoreSyn
-
-import DsUtils ( EquationInfo(..),
- MatchResult(..),
- EqnSet,
- CanItFail(..),
+import DsUtils ( EquationInfo(..), MatchResult(..), EqnSet, CanItFail(..),
tidyLitPat
)
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 Name ( Name, mkLocalName, getOccName, isDataSymOcc, getName, mkVarOcc )
+import Type ( splitAlgTyConApp, mkTyVarTys, splitTyConApp_maybe )
import TysWiredIn ( nilDataCon, consDataCon,
- mkTupleTy, tupleCon,
- mkUnboxedTupleTy, unboxedTupleCon,
- mkListTy,
- charTy, charDataCon,
- intTy, intDataCon,
- floatTy, floatDataCon,
- doubleTy, doubleDataCon,
- addrTy, addrDataCon,
- wordTy, wordDataCon,
- stringTy
+ mkListTy, mkTupleTy, tupleCon
)
-import Unique ( unboundKey )
-import TyCon ( tyConDataCons )
+import PrelNames ( unboundKey )
+import TyCon ( tyConDataCons, tupleTyConBoxity, isTupleTyCon )
+import BasicTypes ( Boxity(..) )
import SrcLoc ( noSrcLoc )
import UniqSet
import Outputable
untidy _ (ListPatIn pats) = ListPatIn (map untidy_no_pars pats)
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
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]
get_unused_cons used_cons = unused_cons
where
(ConPat _ ty _ _ _) = head used_cons
- Just (ty_con,_) = splitTyConApp_maybe ty
+ Just (ty_con,_) = sTyConApp_maybe used_cons ty
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)
+sTyConApp_maybe used_cons ty =
+ case splitTyConApp_maybe ty of
+ Just x -> Just x
+ Nothing -> pprTrace "splitTyConApp_maybe" (ppr (used_cons, ty)) $ Nothing
all_vars :: [TypecheckedPat] -> Bool
all_vars [] = True
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)
+ | isTupleTyCon tc = (TuplePatIn pats_con (tupleTyConBoxity tc) : 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
+ tc = dataConTyCon id
make_whole_con :: DataCon -> WarningPat
where list_ty = mkListTy ty
-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
| 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
+simplify_pat pat@(NPat lit lit_ty hsexpr) = tidyLitPat lit 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)