We must record the type of a TuplePat after typechecking, just like a ConPatOut,
so that desugaring works correctly for GADTs. See comments with the declaration
of HsPat.TuplePat, and test gadt15
import HsSyn
-import TcHsSyn ( hsPatType )
+import TcHsSyn ( hsPatType, mkVanillaTuplePat )
import TcType ( tcTyConAppTyCon )
import DsUtils ( EquationInfo(..), MatchResult(..),
CanItFail(..), firstPat )
untidy' _ p@(ConPatIn name (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 boxed) = TuplePat (map untidy_no_pars pats) boxed
+ 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"
| isInfixCon id = (nlInfixConPat (getName id) lp lq : ps, constraints)
where q = unLoc lq
-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)
+make_con (ConPatOut (L _ id) _ _ _ (PrefixCon pats) ty) (ps, constraints)
+ | isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) ty) : rest_pats, constraints)
+ | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType) : rest_pats, constraints)
| otherwise = (nlConPat name pats_con : rest_pats, constraints)
where
name = getName id
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 (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
(PrefixCon (map simplify_lpat ps))
(mkPArrTy ty)
-simplify_pat (TuplePat ps boxity)
+simplify_pat (TuplePat ps boxity ty)
= mk_simple_con_pat (tupleCon boxity arity)
(PrefixCon (map simplify_lpat ps))
- (mkTupleTy boxity arity (map hsPatType ps))
+ ty
where
arity = length ps
simplify_pat (DictPat dicts methods)
= case num_of_d_and_ms of
- 0 -> simplify_pat (TuplePat [] Boxed)
+ 0 -> simplify_pat (TuplePat [] Boxed unitTy)
1 -> simplify_pat (head dict_and_method_pats)
- _ -> simplify_pat (TuplePat (map noLoc dict_and_method_pats) Boxed)
+ _ -> 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)
#endif
import HsSyn
-import TcHsSyn ( hsPatType )
+import TcHsSyn ( hsPatType, mkVanillaTuplePat )
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
-- needs to see source types (newtypes etc), and sometimes not
mk_tup_pat :: [LPat Id] -> LPat Id
mk_tup_pat [p] = p
- mk_tup_pat ps = noLoc $ TuplePat ps Boxed
+ mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed
mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id
mk_ret_tup [r] = r
import BasicTypes ( Boxity(..) )
import HsSyn
-import TcHsSyn ( hsPatType )
+import TcHsSyn ( hsPatType, mkVanillaTuplePat )
import CoreSyn
import DsMonad -- the monadery used in the desugarer
bndrs_s = map snd stmtss_w_bndrs
-- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
- pat = noLoc (TuplePat pats Boxed)
+ pat = mkTuplePat pats
pats = map mk_hs_tuple_pat bndrs_s
-- Types of (x1,..,xn), (y1,..,yn) etc
mk_hs_tuple_expr ids = noLoc $ ExplicitTuple [ nlHsVar i | i <- ids ] Boxed
mk_hs_tuple_pat :: [Id] -> LPat Id
-mk_hs_tuple_pat [b] = nlVarPat b
-mk_hs_tuple_pat bs = noLoc $ TuplePat (map nlVarPat bs) Boxed
+mk_hs_tuple_pat bs = mkTuplePat (map nlVarPat bs)
\end{code}
-- Smart constructor for source tuple patterns
--
-mkTuplePat :: [LPat id] -> LPat id
+mkTuplePat :: [LPat Id] -> LPat Id
mkTuplePat [lpat] = lpat
-mkTuplePat lpats = noLoc $ TuplePat lpats Boxed
+mkTuplePat lpats = noLoc $ mkVanillaTuplePat lpats Boxed
-- Smart constructor for source tuple expressions
--
repLP (L _ p) = repP p
repP :: Pat Name -> DsM (Core TH.PatQ)
-repP (WildPat _) = repPwild
-repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
-repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
-repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
-repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
-repP (ParPat p) = repLP p
-repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs }
-repP (TuplePat ps _) = do { qs <- repLPs ps; repPtup qs }
+repP (WildPat _) = repPwild
+repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
+repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
+repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
+repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
+repP (ParPat p) = repLP p
+repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs }
+repP (TuplePat ps _ _) = do { qs <- repLPs ps; repPtup qs }
repP (ConPatIn dc details)
= do { con_str <- lookupLOcc dc
; case details of
is_simple_lpat p = is_simple_pat (unLoc p)
- is_simple_pat (TuplePat ps Boxed) = all is_triv_lpat ps
+ is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps
is_simple_pat (ConPatOut _ _ _ _ ps _) = all is_triv_lpat (hsConArgs ps)
is_simple_pat (VarPat _) = True
is_simple_pat (ParPat p) = is_simple_lpat p
import DynFlags ( DynFlag(..), dopt )
import HsSyn
-import TcHsSyn ( hsPatType )
+import TcHsSyn ( mkVanillaTuplePat )
import Check ( check, ExhaustivePat )
import CoreSyn
import CoreUtils ( bindNonRec, exprType )
import PrelInfo ( pAT_ERROR_ID )
import TcType ( Type, tcTyConAppArgs )
import Type ( splitFunTysN, mkTyVarTys )
-import TysWiredIn ( consDataCon, mkTupleTy, mkListTy,
+import TysWiredIn ( consDataCon, mkListTy, unitTy,
tupleCon, parrFakeCon, mkPArrTy )
import BasicTypes ( Boxity(..) )
import ListSetOps ( runs )
arity = length pats
parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
-tidy1 v wrap (TuplePat pats boxity)
+tidy1 v wrap (TuplePat pats boxity ty)
= returnDs (wrap, unLoc tuple_ConPat)
where
arity = length pats
- tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats
- (mkTupleTy boxity arity (map hsPatType pats))
+ tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats ty
tidy1 v wrap (DictPat dicts methods)
= case num_of_d_and_ms of
- 0 -> tidy1 v wrap (TuplePat [] Boxed)
+ 0 -> tidy1 v wrap (TuplePat [] Boxed unitTy)
1 -> tidy1 v wrap (unLoc (head dict_and_method_pats))
- _ -> tidy1 v wrap (TuplePat dict_and_method_pats Boxed)
+ _ -> tidy1 v wrap (mkVanillaTuplePat dict_and_method_pats Boxed)
where
num_of_d_and_ms = length dicts + length methods
dict_and_method_pats = map nlVarPat (dicts ++ methods)
#include "HsVersions.h"
+import Id( idType )
+
import {-# SOURCE #-} Match ( match )
import HsSyn ( Pat(..), HsConDetails(..) )
| otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' }
cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' }
cvtp (TupP [p]) = cvtp p
-cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed }
+cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') }
cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
; return $ ConPatIn s' (InfixCon p1' p2') }
| TuplePat [LPat id] -- Tuple
Boxity -- UnitPat is TuplePat []
+ PostTcType
+ -- You might think that the PostTcType was redundant, but it's essential
+ -- data T a where
+ -- T1 :: Int -> T Int
+ -- f :: (T a, a) -> Int
+ -- f (T1 x, z) = z
+ -- When desugaring, we must generate
+ -- f = /\a. \v::a. case v of (t::T a, w::a) ->
+ -- case t of (T1 (x::Int)) ->
+ -- Note the (w::a), NOT (w::Int), because we have not yet
+ -- refined 'a' to Int. So we must know that the second component
+ -- of the tuple is of type 'a' not Int. See selectMatchVar
| PArrPat [LPat id] -- Syntactic parallel array
PostTcType -- The type of the elements
pprPat :: (OutputableBndr name) => Pat name -> SDoc
-pprPat (VarPat var) = pprPatBndr var
-pprPat (VarPatOut var bs) = parens (pprPatBndr var <+> braces (ppr bs))
-pprPat (WildPat _) = char '_'
-pprPat (LazyPat pat) = char '~' <> ppr pat
-pprPat (AsPat name pat) = parens (hcat [ppr name, char '@', ppr pat])
-pprPat (ParPat pat) = parens (ppr pat)
+pprPat (VarPat var) = pprPatBndr var
+pprPat (VarPatOut var bs) = parens (pprPatBndr var <+> braces (ppr bs))
+pprPat (WildPat _) = char '_'
+pprPat (LazyPat pat) = char '~' <> ppr pat
+pprPat (AsPat name pat) = parens (hcat [ppr name, char '@', ppr pat])
+pprPat (ParPat pat) = parens (ppr pat)
-pprPat (ListPat pats _) = brackets (interpp'SP pats)
-pprPat (PArrPat pats _) = pabrackets (interpp'SP pats)
-pprPat (TuplePat pats bx) = tupleParens bx (interpp'SP pats)
+pprPat (ListPat pats _) = brackets (interpp'SP pats)
+pprPat (PArrPat pats _) = pabrackets (interpp'SP pats)
+pprPat (TuplePat pats bx _) = tupleParens bx (interpp'SP pats)
pprPat (ConPatIn con details) = pprUserCon con details
pprPat (ConPatOut con tvs dicts binds details _)
isConPat (ConPatOut _ _ _ _ _ _) = True
isConPat (ListPat _ _) = True
isConPat (PArrPat _ _) = True
-isConPat (TuplePat _ _) = True
+isConPat (TuplePat _ _ _) = True
isConPat (DictPat ds ms) = (length ds + length ms) > 1
isConPat other = False
where
go (L _ pat) = go1 pat
- go1 (WildPat _) = True
- go1 (VarPat _) = True
- go1 (VarPatOut _ _) = True
- go1 (LazyPat pat) = True
- go1 (ParPat pat) = go pat
- go1 (AsPat _ pat) = go pat
- go1 (SigPatIn pat _) = go pat
- go1 (SigPatOut pat _) = go pat
- go1 (TuplePat pats _) = all go pats
- go1 (ListPat pats _) = False
- go1 (PArrPat pats _) = False -- ?
+ go1 (WildPat _) = True
+ go1 (VarPat _) = True
+ go1 (VarPatOut _ _) = True
+ go1 (LazyPat pat) = True
+ go1 (ParPat pat) = go pat
+ go1 (AsPat _ pat) = go pat
+ go1 (SigPatIn pat _) = go pat
+ go1 (SigPatOut pat _) = go pat
+ go1 (TuplePat pats _ _) = all go pats
+ go1 (ListPat pats _) = False
+ go1 (PArrPat pats _) = False -- ?
go1 (ConPatIn _ _) = False -- Conservative
go1 (ConPatOut (L _ con) _ _ _ details _)
nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
(PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
-nlTuplePat pats box = noLoc (TuplePat pats box)
+nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking
nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
go (ListPat pats _) = foldr collectl bndrs pats
go (PArrPat pats _) = foldr collectl bndrs pats
- go (TuplePat pats _) = foldr collectl bndrs pats
+ go (TuplePat pats _ _) = foldr collectl bndrs pats
go (ConPatIn c ps) = foldr collectl bndrs (hsConArgs ps)
go (ConPatOut c _ ds bs ps _) = map noLoc ds
collect_lpat pat acc = collect_pat (unLoc pat) acc
-collect_pat (SigPatIn pat ty) acc = collect_lpat pat (ty:acc)
-collect_pat (TypePat ty) acc = ty:acc
-
-collect_pat (LazyPat pat) acc = collect_lpat pat acc
-collect_pat (AsPat a pat) acc = collect_lpat pat acc
-collect_pat (ParPat pat) acc = collect_lpat pat acc
-collect_pat (ListPat pats _) acc = foldr collect_lpat acc pats
-collect_pat (PArrPat pats _) acc = foldr collect_lpat acc pats
-collect_pat (TuplePat pats _) acc = foldr collect_lpat acc pats
-collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConArgs ps)
-collect_pat other acc = acc -- Literals, vars, wildcard
+collect_pat (SigPatIn pat ty) acc = collect_lpat pat (ty:acc)
+collect_pat (TypePat ty) acc = ty:acc
+
+collect_pat (LazyPat pat) acc = collect_lpat pat acc
+collect_pat (AsPat a pat) acc = collect_lpat pat acc
+collect_pat (ParPat pat) acc = collect_lpat pat acc
+collect_pat (ListPat pats _) acc = foldr collect_lpat acc pats
+collect_pat (PArrPat pats _) acc = foldr collect_lpat acc pats
+collect_pat (TuplePat pats _ _) acc = foldr collect_lpat acc pats
+collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConArgs ps)
+collect_pat other acc = acc -- Literals, vars, wildcard
\end{code}
return (PArrPat ps placeHolderType)
ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
- return (TuplePat ps b)
+ return (TuplePat ps b placeHolderType)
RecordCon c _ fs -> mapM checkPatField fs >>= \fs ->
return (ConPatIn c (RecCon fs))
where
implicit_fvs = mkFVs [lengthPName, indexPName]
-rnPat (TuplePat pats boxed)
+rnPat (TuplePat pats boxed _)
= checkTupSize tup_size `thenM_`
rnLPats pats `thenM` \ (patslist, fvs) ->
- returnM (TuplePat patslist boxed, fvs `addOneFV` tycon_name)
+ returnM (TuplePat patslist boxed placeHolderType,
+ fvs `addOneFV` tycon_name)
where
tup_size = length pats
tycon_name = tupleTyCon_name boxed tup_size
import TcHsType ( tcHsSigType, UserTypeCtxt(..) )
import TcPat ( tcOverloadedLit, badFieldCon )
import TcMType ( tcInstTyVars, newFlexiTyVarTy, newBoxyTyVars, readFilledBox,
- tcInstBoxyTyVar, tcInstTyVar, zonkTcType )
+ tcInstBoxyTyVar, tcInstTyVar )
import TcType ( TcType, TcSigmaType, TcRhoType,
BoxySigmaType, BoxyRhoType, ThetaType,
- tcSplitFunTys, mkTyVarTys, mkFunTys,
- tcMultiSplitSigmaTy, tcSplitFunTysN,
+ mkTyVarTys, mkFunTys, tcMultiSplitSigmaTy, tcSplitFunTysN,
isSigmaTy, mkFunTy, mkTyConApp, isLinearPred,
exactTyVarsOfType, exactTyVarsOfTypes, mkTyVarTy,
- tidyOpenType,
zipTopTvSubst, zipOpenTvSubst, substTys, substTyVar, lookupTyVar
)
import Kind ( argTypeKind )
mkHsTyApp, mkHsDictApp, mkHsConApp,
mkHsTyLam, mkHsDictLam, mkHsDictLet, mkHsApp,
hsLitType, hsPatType, mkHsAppTy, mkSimpleHsAlt,
- nlHsIntLit,
+ nlHsIntLit, mkVanillaTuplePat,
-- re-exported from TcMonad
Note: If @hsPatType@ doesn't bear a strong resemblance to @exprType@,
then something is wrong.
\begin{code}
+mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
+-- A vanilla tuple pattern simply gets its type from its sub-patterns
+mkVanillaTuplePat pats box
+ = TuplePat pats box (mkTupleTy box (length pats) (map hsPatType pats))
+
hsPatType :: OutPat Id -> Type
hsPatType pat = pat_type (unLoc pat)
pat_type (AsPat var pat) = idType (unLoc var)
pat_type (ListPat _ ty) = mkListTy ty
pat_type (PArrPat _ ty) = mkPArrTy ty
-pat_type (TuplePat pats box) = mkTupleTy box (length pats) (map hsPatType pats)
+pat_type (TuplePat pats box ty) = ty
pat_type (ConPatOut _ _ _ _ _ ty) = ty
pat_type (SigPatOut pat ty) = ty
pat_type (NPat lit _ _ ty) = ty
; (env', pats') <- zonkPats env pats
; return (env', PArrPat pats' ty') }
-zonk_pat env (TuplePat pats boxed)
- = do { (env', pats') <- zonkPats env pats
- ; return (env', TuplePat pats' boxed) }
+zonk_pat env (TuplePat pats boxed ty)
+ = do { ty' <- zonkTcTypeToType env ty
+ ; (env', pats') <- zonkPats env pats
+ ; return (env', TuplePat pats' boxed ty') }
zonk_pat env (ConPatOut n tvs dicts binds stuff ty)
= ASSERT( all isImmutableTyVar tvs )
; ifM (null pats) (zapToMonotype pat_ty) -- c.f. ExplicitPArr in TcExpr
; return (PArrPat pats' elt_ty, pats_tvs, res) }
-tc_pat pstate (TuplePat pats boxity) pat_ty thing_inside
+tc_pat pstate (TuplePat pats boxity _) pat_ty thing_inside
= do { arg_tys <- boxySplitTyConApp (tupleTyCon boxity (length pats)) pat_ty
; (pats', pats_tvs, res) <- tc_lpats pstate pats arg_tys thing_inside
-- so that we can experiment with lazy tuple-matching.
-- This is a pretty odd place to make the switch, but
-- it was easy to do.
- ; let unmangled_result = TuplePat pats' boxity
+ ; let unmangled_result = TuplePat pats' boxity pat_ty
possibly_mangled_result
| opt_IrrefutableTuples && isBoxed boxity = LazyPat (noLoc unmangled_result)
| otherwise = unmangled_result
toEP = mkHsLam [noLoc tuple_pat] (noLoc to_body) }
where
names = takeList eps gs_RDR
- tuple_pat = TuplePat (map nlVarPat names) Boxed
+ tuple_pat = TuplePat (map nlVarPat names) Boxed placeHolderType
eps_w_names = eps `zip` names
to_body = ExplicitTuple [toEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed
from_body = ExplicitTuple [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed
projects / ghc-hetmet.git / commitdiff