Commit 0ff152c9 authored by Alan Zimmerman's avatar Alan Zimmerman

WIP on combining Step 1 and 3 of Trees That Grow

See https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow

Trees that grow extension points are added for
- ValBinds
- HsPat
- HsLit
- HsOverLit
- HsType
- HsTyVarBndr
- HsAppType
- FieldOcc
- AmbiguousFieldOcc

Updates haddock submodule

Test Plan: ./validate

Reviewers: shayan-najd, simonpj, austin, goldfire, bgamari

Subscribers: goldfire, rwbarton, thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D4147
parent 275ac8ef
......@@ -723,25 +723,25 @@ mkLitPattern lit = PmLit { pm_lit_lit = PmSLit lit }
translatePat :: FamInstEnvs -> Pat GhcTc -> DsM PatVec
translatePat fam_insts pat = case pat of
WildPat ty -> mkPmVars [ty]
VarPat id -> return [PmVar (unLoc id)]
ParPat p -> translatePat fam_insts (unLoc p)
LazyPat _ -> mkPmVars [hsPatType pat] -- like a variable
WildPat ty -> mkPmVars [ty]
VarPat _ id -> return [PmVar (unLoc id)]
ParPat _ p -> translatePat fam_insts (unLoc p)
LazyPat _ _ -> mkPmVars [hsPatType pat] -- like a variable
-- ignore strictness annotations for now
BangPat p -> translatePat fam_insts (unLoc p)
BangPat _ p -> translatePat fam_insts (unLoc p)
AsPat lid p -> do
AsPat _ lid p -> do
-- Note [Translating As Patterns]
ps <- translatePat fam_insts (unLoc p)
let [e] = map vaToPmExpr (coercePatVec ps)
g = PmGrd [PmVar (unLoc lid)] e
return (ps ++ [g])
SigPatOut p _ty -> translatePat fam_insts (unLoc p)
SigPat _ty p -> translatePat fam_insts (unLoc p)
-- See Note [Translate CoPats]
CoPat wrapper p ty
CoPat _ wrapper p ty
| isIdHsWrapper wrapper -> translatePat fam_insts p
| WpCast co <- wrapper, isReflexiveCo co -> translatePat fam_insts p
| otherwise -> do
......@@ -751,10 +751,10 @@ translatePat fam_insts pat = case pat of
return [xp,g]
-- (n + k) ===> x (True <- x >= k) (n <- x-k)
NPlusKPat (L _ _n) _k1 _k2 _ge _minus ty -> mkCanFailPmPat ty
NPlusKPat ty (L _ _n) _k1 _k2 _ge _minus -> mkCanFailPmPat ty
-- (fun -> pat) ===> x (pat <- fun x)
ViewPat lexpr lpat arg_ty -> do
ViewPat arg_ty lexpr lpat -> do
ps <- translatePat fam_insts (unLoc lpat)
-- See Note [Guards and Approximation]
case all cantFailPattern ps of
......@@ -765,12 +765,12 @@ translatePat fam_insts pat = case pat of
False -> mkCanFailPmPat arg_ty
-- list
ListPat ps ty Nothing -> do
ListPat (ListPatTc ty Nothing) ps -> do
foldr (mkListPatVec ty) [nilPattern ty]
<$> translatePatVec fam_insts (map unLoc ps)
-- overloaded list
ListPat lpats elem_ty (Just (pat_ty, _to_list))
ListPat (ListPatTc elem_ty (Just (pat_ty, _to_list))) lpats
| Just e_ty <- splitListTyConApp_maybe pat_ty
, (_, norm_elem_ty) <- normaliseType fam_insts Nominal elem_ty
-- elem_ty is frequently something like
......@@ -779,7 +779,7 @@ translatePat fam_insts pat = case pat of
-- We have to ensure that the element types are exactly the same.
-- Otherwise, one may give an instance IsList [Int] (more specific than
-- the default IsList [a]) with a different implementation for `toList'
translatePat fam_insts (ListPat lpats e_ty Nothing)
translatePat fam_insts (ListPat (ListPatTc e_ty Nothing) lpats)
-- See Note [Guards and Approximation]
| otherwise -> mkCanFailPmPat pat_ty
......@@ -799,26 +799,27 @@ translatePat fam_insts pat = case pat of
, pm_con_dicts = dicts
, pm_con_args = args }]
NPat (L _ ol) mb_neg _eq ty -> translateNPat fam_insts ol mb_neg ty
NPat ty (L _ ol) mb_neg _eq -> translateNPat fam_insts ol mb_neg ty
LitPat lit
LitPat _ lit
-- If it is a string then convert it to a list of characters
| HsString src s <- lit ->
foldr (mkListPatVec charTy) [nilPattern charTy] <$>
translatePatVec fam_insts (map (LitPat . HsChar src) (unpackFS s))
translatePatVec fam_insts
(map (LitPat noExt . HsChar src) (unpackFS s))
| otherwise -> return [mkLitPattern lit]
PArrPat ps ty -> do
PArrPat ty ps -> do
tidy_ps <- translatePatVec fam_insts (map unLoc ps)
let fake_con = RealDataCon (parrFakeCon (length ps))
return [vanillaConPattern fake_con [ty] (concat tidy_ps)]
TuplePat ps boxity tys -> do
TuplePat tys ps boxity -> do
tidy_ps <- translatePatVec fam_insts (map unLoc ps)
let tuple_con = RealDataCon (tupleDataCon boxity (length ps))
return [vanillaConPattern tuple_con tys (concat tidy_ps)]
SumPat p alt arity ty -> do
SumPat ty p alt arity -> do
tidy_p <- translatePat fam_insts (unLoc p)
let sum_con = RealDataCon (sumDataCon alt arity)
return [vanillaConPattern sum_con ty tidy_p]
......@@ -827,23 +828,23 @@ translatePat fam_insts pat = case pat of
-- Not supposed to happen
ConPatIn {} -> panic "Check.translatePat: ConPatIn"
SplicePat {} -> panic "Check.translatePat: SplicePat"
SigPatIn {} -> panic "Check.translatePat: SigPatIn"
XPat {} -> panic "Check.translatePat: XPat"
-- | Translate an overloaded literal (see `tidyNPat' in deSugar/MatchLit.hs)
translateNPat :: FamInstEnvs
-> HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> Type
-> DsM PatVec
translateNPat fam_insts (OverLit val False _ ty) mb_neg outer_ty
translateNPat fam_insts (OverLit (OverLitTc False ty) val _ ) mb_neg outer_ty
| not type_change, isStringTy ty, HsIsString src s <- val, Nothing <- mb_neg
= translatePat fam_insts (LitPat (HsString src s))
= translatePat fam_insts (LitPat noExt (HsString src s))
| not type_change, isIntTy ty, HsIntegral i <- val
= translatePat fam_insts
(LitPat $ case mb_neg of
Nothing -> HsInt def i
Just _ -> HsInt def (negateIntegralLit i))
(LitPat noExt $ case mb_neg of
Nothing -> HsInt noExt i
Just _ -> HsInt noExt (negateIntegralLit i))
| not type_change, isWordTy ty, HsIntegral i <- val
= translatePat fam_insts
(LitPat $ case mb_neg of
(LitPat noExt $ case mb_neg of
Nothing -> HsWordPrim (il_text i) (il_value i)
Just _ -> let ni = negateIntegralLit i in
HsWordPrim (il_text ni) (il_value ni))
......
......@@ -1187,31 +1187,31 @@ collectl :: LPat GhcTc -> [Id] -> [Id]
collectl (L _ pat) bndrs
= go pat
where
go (VarPat (L _ var)) = var : bndrs
go (VarPat _ (L _ var)) = var : bndrs
go (WildPat _) = bndrs
go (LazyPat pat) = collectl pat bndrs
go (BangPat pat) = collectl pat bndrs
go (AsPat (L _ a) pat) = a : collectl pat bndrs
go (ParPat pat) = collectl pat bndrs
go (LazyPat _ pat) = collectl pat bndrs
go (BangPat _ pat) = collectl pat bndrs
go (AsPat _ (L _ a) pat) = a : collectl pat bndrs
go (ParPat _ pat) = collectl pat bndrs
go (ListPat pats _ _) = foldr collectl bndrs pats
go (PArrPat pats _) = foldr collectl bndrs pats
go (TuplePat pats _ _) = foldr collectl bndrs pats
go (SumPat pat _ _ _) = collectl pat bndrs
go (ListPat _ pats ) = foldr collectl bndrs pats
go (PArrPat _ pats) = foldr collectl bndrs pats
go (TuplePat _ pats _) = foldr collectl bndrs pats
go (SumPat _ pat _ _) = collectl pat bndrs
go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps)
go (ConPatOut {pat_args=ps, pat_binds=ds}) =
collectEvBinders ds
++ foldr collectl bndrs (hsConPatArgs ps)
go (LitPat _) = bndrs
go (LitPat _ _) = bndrs
go (NPat {}) = bndrs
go (NPlusKPat (L _ n) _ _ _ _ _) = n : bndrs
go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs
go (SigPatIn pat _) = collectl pat bndrs
go (SigPatOut pat _) = collectl pat bndrs
go (CoPat _ pat _) = collectl (noLoc pat) bndrs
go (ViewPat _ pat _) = collectl pat bndrs
go (SigPat _ pat) = collectl pat bndrs
go (CoPat _ _ pat _) = collectl (noLoc pat) bndrs
go (ViewPat _ _ pat) = collectl pat bndrs
go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p)
go p@(XPat {}) = pprPanic "collectl/go" (ppr p)
collectEvBinders :: TcEvBinds -> [Id]
collectEvBinders (EvBinds bs) = foldrBag add_ev_bndr [] bs
......
......@@ -973,7 +973,7 @@ dsDo stmts
[mfix_pat] body]
, mg_arg_tys = [tup_ty], mg_res_ty = body_ty
, mg_origin = Generated })
mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTupId rec_tup_pats
mfix_pat = noLoc $ LazyPat noExt $ mkBigLHsPatTupId rec_tup_pats
body = noLoc $ HsDo
DoExpr (noLoc (rec_stmts ++ [ret_stmt])) body_ty
ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets]
......
......@@ -198,8 +198,8 @@ hsSigTvBinders binds
get_scoped_tvs _ = []
sigs = case binds of
ValBindsIn _ sigs -> sigs
ValBindsOut _ sigs -> sigs
ValBindsIn _ _ sigs -> sigs
ValBindsOut _ sigs -> sigs
{- Notes
......@@ -695,7 +695,7 @@ repBangTy ty = do
rep2 bangTypeName [b, t]
where
(su', ss', ty') = case ty of
L _ (HsBangTy (HsSrcBang _ su ss) ty) -> (su, ss, ty)
L _ (HsBangTy _ (HsSrcBang _ su ss) ty) -> (su, ss, ty)
_ -> (NoSrcUnpack, NoSrcStrict, ty)
-------------------------------------------------------
......@@ -917,18 +917,20 @@ addTyClTyVarBinds tvs m
--
repTyVarBndrWithKind :: LHsTyVarBndr GhcRn
-> Core TH.Name -> DsM (Core TH.TyVarBndrQ)
repTyVarBndrWithKind (L _ (UserTyVar _)) nm
repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm
= repPlainTV nm
repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm
= repLTy ki >>= repKindedTV nm
repTyVarBndrWithKind (L _ (XTyVarBndr{})) _ = panic "repTyVarBndrWithKind"
-- | Represent a type variable binder
repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)
repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm
; repPlainTV nm' }
repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm
; ki' <- repLTy ki
; repKindedTV nm' ki' }
repTyVarBndr (L _ (UserTyVar _ (L _ nm)) )= do { nm' <- lookupBinder nm
; repPlainTV nm' }
repTyVarBndr (L _ (KindedTyVar _ (L _ nm) ki)) = do { nm' <- lookupBinder nm
; ki' <- repLTy ki
; repKindedTV nm' ki' }
repTyVarBndr (L _ (XTyVarBndr{})) = panic "repTyVarBndr"
-- represent a type context
--
......@@ -1000,7 +1002,7 @@ repTy :: HsType GhcRn -> DsM (Core TH.TypeQ)
repTy ty@(HsForAllTy {}) = repForall ty
repTy ty@(HsQualTy {}) = repForall ty
repTy (HsTyVar _ (L _ n))
repTy (HsTyVar _ _ (L _ n))
| isLiftedTypeKindTyConName n = repTStar
| n `hasKey` constraintKindTyConKey = repTConstraint
| isTvOcc occ = do tv1 <- lookupOcc n
......@@ -1013,47 +1015,47 @@ repTy (HsTyVar _ (L _ n))
where
occ = nameOccName n
repTy (HsAppTy f a) = do
repTy (HsAppTy _ f a) = do
f1 <- repLTy f
a1 <- repLTy a
repTapp f1 a1
repTy (HsFunTy f a) = do
repTy (HsFunTy _ f a) = do
f1 <- repLTy f
a1 <- repLTy a
tcon <- repArrowTyCon
repTapps tcon [f1, a1]
repTy (HsListTy t) = do
repTy (HsListTy _ t) = do
t1 <- repLTy t
tcon <- repListTyCon
repTapp tcon t1
repTy (HsPArrTy t) = do
repTy (HsPArrTy _ t) = do
t1 <- repLTy t
tcon <- repTy (HsTyVar NotPromoted
tcon <- repTy (HsTyVar noExt NotPromoted
(noLoc (tyConName parrTyCon)))
repTapp tcon t1
repTy (HsTupleTy HsUnboxedTuple tys) = do
repTy (HsTupleTy _ HsUnboxedTuple tys) = do
tys1 <- repLTys tys
tcon <- repUnboxedTupleTyCon (length tys)
repTapps tcon tys1
repTy (HsTupleTy _ tys) = do tys1 <- repLTys tys
repTy (HsTupleTy _ _ tys) = do tys1 <- repLTys tys
tcon <- repTupleTyCon (length tys)
repTapps tcon tys1
repTy (HsSumTy tys) = do tys1 <- repLTys tys
repTy (HsSumTy _ tys) = do tys1 <- repLTys tys
tcon <- repUnboxedSumTyCon (length tys)
repTapps tcon tys1
repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
repTy (HsOpTy _ ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
`nlHsAppTy` ty2)
repTy (HsParTy t) = repLTy t
repTy (HsEqTy t1 t2) = do
repTy (HsParTy _ t) = repLTy t
repTy (HsEqTy _ t1 t2) = do
t1' <- repLTy t1
t2' <- repLTy t2
eq <- repTequality
repTapps eq [t1', t2']
repTy (HsKindSig t k) = do
repTy (HsKindSig _ t k) = do
t1 <- repLTy t
k1 <- repLTy k
repTSig t1 k1
repTy (HsSpliceTy splice _) = repSplice splice
repTy (HsSpliceTy _ splice) = repSplice splice
repTy (HsExplicitListTy _ _ tys) = do
tys1 <- repLTys tys
repTPromotedList tys1
......@@ -1061,9 +1063,9 @@ repTy (HsExplicitTupleTy _ tys) = do
tys1 <- repLTys tys
tcon <- repPromotedTupleTyCon (length tys)
repTapps tcon tys1
repTy (HsTyLit lit) = do
lit' <- repTyLit lit
repTLit lit'
repTy (HsTyLit _ lit) = do
lit' <- repTyLit lit
repTLit lit'
repTy (HsWildCardTy (AnonWildCard _)) = repTWildCard
repTy ty = notHandled "Exotic form of type" (ppr ty)
......@@ -1137,8 +1139,9 @@ repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
repE (HsOverLabel _ s) = repOverLabel s
repE e@(HsRecFld f) = case f of
Unambiguous _ x -> repE (HsVar (noLoc x))
Unambiguous x _ -> repE (HsVar (noLoc x))
Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e)
XAmbiguousFieldOcc{} -> notHandled "XAmbiguous record selectors" (ppr e)
-- Remember, we're desugaring renamer output here, so
-- HsOverlit can definitely occur
......@@ -1318,7 +1321,7 @@ repUpdFields = repList fieldExpQTyConName rep_fld
where
rep_fld :: LHsRecUpdField GhcRn -> DsM (Core (TH.Q TH.FieldExp))
rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of
Unambiguous _ sel_name -> do { fn <- lookupLOcc (L l sel_name)
Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name)
; e <- repLE (hsRecFieldArg fld)
; repFieldExp fn e }
_ -> notHandled "Ambiguous record updates" (ppr fld)
......@@ -1424,7 +1427,7 @@ rep_val_binds (ValBindsOut binds sigs)
= do { core1 <- rep_binds' (unionManyBags (map snd binds))
; core2 <- rep_sigs' sigs
; return (core1 ++ core2) }
rep_val_binds (ValBindsIn _ _)
rep_val_binds (ValBindsIn _ _ _)
= panic "rep_val_binds: ValBindsIn"
rep_binds :: LHsBinds GhcRn -> DsM [Core TH.DecQ]
......@@ -1611,19 +1614,23 @@ repLP :: LPat GhcRn -> DsM (Core TH.PatQ)
repLP (L _ p) = repP p
repP :: Pat GhcRn -> DsM (Core TH.PatQ)
repP (WildPat _) = repPwild
repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
repP (VarPat (L _ x)) = do { x' <- lookupBinder x; repPvar x' }
repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
repP (BangPat p) = do { p1 <- repLP p; repPbang p1 }
repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
repP (ParPat p) = repLP p
repP (ListPat ps _ Nothing) = do { qs <- repLPs ps; repPlist qs }
repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE (syn_expr e); repPview e' p}
repP (TuplePat ps boxed _)
repP (WildPat _) = repPwild
repP (LitPat _ l) = do { l2 <- repLiteral l; repPlit l2 }
repP (VarPat _ (L _ x)) = do { x' <- lookupBinder x; repPvar x' }
repP (LazyPat _ p) = do { p1 <- repLP p; repPtilde p1 }
repP (BangPat _ p) = do { p1 <- repLP p; repPbang p1 }
repP (AsPat _ x p) = do { x' <- lookupLBinder x; p1 <- repLP p
; repPaspat x' p1 }
repP (ParPat _ p) = repLP p
repP (ListPat Nothing ps) = do { qs <- repLPs ps; repPlist qs }
repP (ListPat (Just e) ps) = do { p <- repP (ListPat Nothing ps)
; e' <- repE (syn_expr e)
; repPview e' p}
repP (TuplePat _ ps boxed)
| isBoxed boxed = do { qs <- repLPs ps; repPtup qs }
| otherwise = do { qs <- repLPs ps; repPunboxedTup qs }
repP (SumPat p alt arity _) = do { p1 <- repLP p; repPunboxedSum p1 alt arity }
repP (SumPat _ p alt arity) = do { p1 <- repLP p
; repPunboxedSum p1 alt arity }
repP (ConPatIn dc details)
= do { con_str <- lookupLOcc dc
; case details of
......@@ -1640,13 +1647,13 @@ repP (ConPatIn dc details)
; MkC p <- repLP (hsRecFieldArg fld)
; rep2 fieldPatName [v,p] }
repP (NPat (L _ l) Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a }
repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
repP p@(NPat _ (Just _) _ _) = notHandled "Negative overloaded patterns" (ppr p)
repP (SigPatIn p t) = do { p' <- repLP p
; t' <- repLTy (hsSigWcType t)
; repPsig p' t' }
repP (SplicePat splice) = repSplice splice
repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
repP (SigPat t p) = do { p' <- repLP p
; t' <- repLTy (hsSigWcType t)
; repPsig p' t' }
repP (SplicePat _ splice) = repSplice splice
repP other = notHandled "Exotic pattern" (ppr other)
......@@ -2197,7 +2204,7 @@ repConstr (RecCon (L _ ips)) resTy cons
rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> DsM (Core a)
rep_one_ip t n = do { MkC v <- lookupOcc (selectorFieldOcc $ unLoc n)
rep_one_ip t n = do { MkC v <- lookupOcc (extFieldOcc $ unLoc n)
; MkC ty <- repBangTy t
; rep2 varBangTypeName [v,ty] }
......@@ -2357,7 +2364,7 @@ mk_integer i = do integer_ty <- lookupType integerTyConName
mk_rational :: FractionalLit -> DsM (HsLit GhcRn)
mk_rational r = do rat_ty <- lookupType rationalTyConName
return $ HsRat def r rat_ty
return $ HsRat noExt r rat_ty
mk_string :: FastString -> DsM (HsLit GhcRn)
mk_string s = return $ HsString noSourceText s
......@@ -2370,6 +2377,7 @@ repOverloadedLiteral (OverLit { ol_val = val})
-- The type Rational will be in the environment, because
-- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
-- and rationalL is sucked in when any TH stuff is used
repOverloadedLiteral XOverLit{} = panic "repOverloadedLiteral"
mk_lit :: OverLitVal -> DsM (HsLit GhcRn)
mk_lit (HsIntegral i) = mk_integer (il_value i)
......
......@@ -9,6 +9,8 @@ This module exports some utility functions of no great interest.
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
-- | Utility functions for constructing Core syntax, principally for desugaring
module DsUtils (
......@@ -117,13 +119,13 @@ selectMatchVars :: [Pat GhcTc] -> DsM [Id]
selectMatchVars ps = mapM selectMatchVar ps
selectMatchVar :: Pat GhcTc -> DsM Id
selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)
selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat)
selectMatchVar (VarPat var) = return (localiseId (unLoc var))
selectMatchVar (BangPat _ pat) = selectMatchVar (unLoc pat)
selectMatchVar (LazyPat _ pat) = selectMatchVar (unLoc pat)
selectMatchVar (ParPat _ pat) = selectMatchVar (unLoc pat)
selectMatchVar (VarPat _ var) = return (localiseId (unLoc var))
-- Note [Localise pattern binders]
selectMatchVar (AsPat var _) = return (unLoc var)
selectMatchVar other_pat = newSysLocalDsNoLP (hsPatType other_pat)
selectMatchVar (AsPat _ var _) = return (unLoc var)
selectMatchVar other_pat = newSysLocalDsNoLP (hsPatType other_pat)
-- OK, better make up one...
{-
......@@ -736,7 +738,7 @@ mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly
-- and all the desugared binds
mkSelectorBinds ticks pat val_expr
| L _ (VarPat (L _ v)) <- pat' -- Special case (A)
| L _ (VarPat _ (L _ v)) <- pat' -- Special case (A)
= return (v, [(v, val_expr)])
| is_flat_prod_lpat pat' -- Special case (B)
......@@ -783,17 +785,17 @@ mkSelectorBinds ticks pat val_expr
strip_bangs :: LPat a -> LPat a
-- Remove outermost bangs and parens
strip_bangs (L _ (ParPat p)) = strip_bangs p
strip_bangs (L _ (BangPat p)) = strip_bangs p
strip_bangs lp = lp
strip_bangs (L _ (ParPat _ p)) = strip_bangs p
strip_bangs (L _ (BangPat _ p)) = strip_bangs p
strip_bangs lp = lp
is_flat_prod_lpat :: LPat a -> Bool
is_flat_prod_lpat p = is_flat_prod_pat (unLoc p)
is_flat_prod_pat :: Pat a -> Bool
is_flat_prod_pat (ParPat p) = is_flat_prod_lpat p
is_flat_prod_pat (TuplePat ps Boxed _) = all is_triv_lpat ps
is_flat_prod_pat (ConPatOut { pat_con = L _ pcon, pat_args = ps})
is_flat_prod_pat (ParPat _ p) = is_flat_prod_lpat p
is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps
is_flat_prod_pat (ConPatOut { pat_con = L _ pcon, pat_args = ps})
| RealDataCon con <- pcon
, isProductTyCon (dataConTyCon con)
= all is_triv_lpat (hsConPatArgs ps)
......@@ -803,10 +805,10 @@ is_triv_lpat :: LPat a -> Bool
is_triv_lpat p = is_triv_pat (unLoc p)
is_triv_pat :: Pat a -> Bool
is_triv_pat (VarPat _) = True
is_triv_pat (WildPat _) = True
is_triv_pat (ParPat p) = is_triv_lpat p
is_triv_pat _ = False
is_triv_pat (VarPat {}) = True
is_triv_pat (WildPat{}) = True
is_triv_pat (ParPat _ p) = is_triv_lpat p
is_triv_pat _ = False
{- *********************************************************************
......@@ -828,7 +830,7 @@ mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs)
mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc
-- A vanilla tuple pattern simply gets its type from its sub-patterns
mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats)
mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box
-- The Big equivalents for the source tuple expressions
mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc
......@@ -983,8 +985,8 @@ mkBinaryTickBox ixT ixF e = do
-- pat => !pat -- when -XStrict
-- pat => pat -- otherwise
decideBangHood :: DynFlags
-> LPat id -- ^ Original pattern
-> LPat id -- Pattern with bang if necessary
-> LPat GhcTc -- ^ Original pattern
-> LPat GhcTc -- Pattern with bang if necessary
decideBangHood dflags lpat
| not (xopt LangExt.Strict dflags)
= lpat
......@@ -993,19 +995,20 @@ decideBangHood dflags lpat
where
go lp@(L l p)
= case p of
ParPat p -> L l (ParPat (go p))
LazyPat lp' -> lp'
BangPat _ -> lp
_ -> L l (BangPat lp)
ParPat x p -> L l (ParPat x (go p))
LazyPat _ lp' -> lp'
BangPat _ _ -> lp
_ -> L l (BangPat noExt lp)
-- | Unconditionally make a 'Pat' strict.
addBang :: LPat id -- ^ Original pattern
-> LPat id -- ^ Banged pattern
addBang :: LPat GhcTc -- ^ Original pattern
-> LPat GhcTc -- ^ Banged pattern
addBang = go
where
go lp@(L l p)
= case p of
ParPat p -> L l (ParPat (go p))
LazyPat lp' -> L l (BangPat lp')
BangPat _ -> lp
_ -> L l (BangPat lp)
ParPat x p -> L l (ParPat x (go p))
LazyPat _ lp' -> L l (BangPat noExt lp')
-- Should we bring the extension value over?
BangPat _ _ -> lp
_ -> L l (BangPat noExt lp)
......@@ -251,7 +251,7 @@ matchBangs [] _ _ = panic "matchBangs"
matchCoercion :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
-- Apply the coercion to the match variable and then match that
matchCoercion (var:vars) ty (eqns@(eqn1:_))
= do { let CoPat co pat _ = firstPat eqn1
= do { let CoPat _ co pat _ = firstPat eqn1
; let pat_ty' = hsPatType pat
; var' <- newUniqueId var pat_ty'
; match_result <- match (var':vars) ty $
......@@ -267,7 +267,7 @@ matchView (var:vars) ty (eqns@(eqn1:_))
= do { -- we could pass in the expr from the PgView,
-- but this needs to extract the pat anyway
-- to figure out the type of the fresh variable
let ViewPat viewExpr (L _ pat) _ = firstPat eqn1
let ViewPat _ viewExpr (L _ pat) = firstPat eqn1
-- do the rest of the compilation
; let pat_ty' = hsPatType pat
; var' <- newUniqueId var pat_ty'
......@@ -284,7 +284,7 @@ matchOverloadedList :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
matchOverloadedList (var:vars) ty (eqns@(eqn1:_))
-- Since overloaded list patterns are treated as view patterns,
-- the code is roughly the same as for matchView
= do { let ListPat _ elt_ty (Just (_,e)) = firstPat eqn1
= do { let ListPat (ListPatTc elt_ty (Just (_,e))) _ = firstPat eqn1
; var' <- newUniqueId var (mkListTy elt_ty) -- we construct the overall type by hand
; match_result <- match (var':vars) ty $
map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern
......@@ -299,13 +299,14 @@ decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
decomposeFirstPat _ _ = panic "decomposeFirstPat"
getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc
getCoPat (CoPat _ pat _