Commit 438dd1cb authored by Alan Zimmerman's avatar Alan Zimmerman

WIP on Doing a combined Step 1 and 3 for 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 fe6848f5
......@@ -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 _ ps ty Nothing -> do
foldr (mkListPatVec ty) [nilPattern ty]
<$> translatePatVec fam_insts (map unLoc ps)
-- overloaded list
ListPat lpats elem_ty (Just (pat_ty, _to_list))
ListPat x lpats elem_ty (Just (pat_ty, _to_list))
| 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 x lpats e_ty Nothing)
-- 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))
......
......@@ -795,15 +795,17 @@ addTickHsLocalBinds (HsIPBinds binds) =
(addTickHsIPBinds binds)
addTickHsLocalBinds (EmptyLocalBinds) = return EmptyLocalBinds
addTickHsValBinds :: HsValBindsLR GhcTc a -> TM (HsValBindsLR GhcTc b)
addTickHsValBinds (ValBindsOut binds sigs) =
liftM2 ValBindsOut
addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)
-> TM (HsValBindsLR GhcTc (GhcPass b))
addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do
b <- liftM2 NValBinds
(mapM (\ (rec,binds') ->
liftM2 (,)
(return rec)
(addTickLHsBinds binds'))
binds)
(return sigs)
return $ XValBindsLR b
addTickHsValBinds _ = panic "addTickHsValBinds"
addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)
......
......@@ -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
......
......@@ -78,8 +78,9 @@ dsLocalBinds (L _ (HsIPBinds binds)) body = dsIPBinds binds body
-------------------------
-- caller sets location
dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
dsValBinds (ValBindsIn {}) _ = panic "dsValBinds ValBindsIn"
dsValBinds (XValBindsLR (NValBinds binds _)) body
= foldrM ds_val_bind body binds
dsValBinds (ValBinds {}) _ = panic "dsValBinds ValBindsIn"
-------------------------
dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
......@@ -973,7 +974,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]
......
This diff is collapsed.
......@@ -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 _ _ 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,13 @@ decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
decomposeFirstPat _ _ = panic "decomposeFirstPat"
getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc
getCoPat (CoPat _ pat _) = pat
getCoPat (CoPat _ _ pat _) = pat
getCoPat _ = panic "getCoPat"
getBangPat (BangPat pat ) = unLoc pat
getBangPat (BangPat _ pat ) = unLoc pat
getBangPat _ = panic "getBangPat"
getViewPat (ViewPat _ pat _) = unLoc pat
getViewPat (ViewPat _ _ pat) = unLoc pat
getViewPat _ = panic "getViewPat"
getOLPat (ListPat pats ty (Just _)) = ListPat pats ty Nothing
getOLPat (ListPat x pats ty (Just _)) = ListPat x pats ty Nothing
getOLPat _ = panic "getOLPat"
{-
......@@ -398,19 +398,19 @@ tidy1 :: Id -- The Id being scrutinised
-- It eliminates many pattern forms (as-patterns, variable patterns,
-- list patterns, etc) and returns any created bindings in the wrapper.
tidy1 v (ParPat pat) = tidy1 v (unLoc pat)
tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat)
tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty)
tidy1 v (BangPat (L l p)) = tidy_bang_pat v l p
tidy1 v (ParPat _ pat) = tidy1 v (unLoc pat)
tidy1 v (SigPat _ pat) = tidy1 v (unLoc pat)
tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty)
tidy1 v (BangPat _ (L l p)) = tidy_bang_pat v l p
-- case v of { x -> mr[] }
-- = case v of { _ -> let x=v in mr[] }
tidy1 v (VarPat (L _ var))
tidy1 v (VarPat _ (L _ var))
= return (wrapBind var v, WildPat (idType var))
-- case v of { x@p -> mr[] }
-- = case v of { p -> let x=v in mr[] }
tidy1 v (AsPat (L _ var) pat)
tidy1 v (AsPat _ (L _ var) pat)
= do { (wrap, pat') <- tidy1 v (unLoc pat)
; return (wrapBind var v . wrap, pat') }
......@@ -425,7 +425,7 @@ tidy1 v (AsPat (L _ var) pat)
The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
-}
tidy1 v (LazyPat pat)
tidy1 v (LazyPat _ pat)
-- This is a convenient place to check for unlifted types under a lazy pattern.
-- Doing this check during type-checking is unsatisfactory because we may
-- not fully know the zonked types yet. We sure do here.
......@@ -441,7 +441,7 @@ tidy1 v (LazyPat pat)
; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]
; return (mkCoreLets sel_binds, WildPat (idType v)) }
tidy1 _ (ListPat pats ty Nothing)
tidy1 _ (ListPat _ pats ty Nothing)
= return (idDsWrapper, unLoc list_ConPat)
where
list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
......@@ -450,29 +450,29 @@ tidy1 _ (ListPat pats ty Nothing)
-- Introduce fake parallel array constructors to be able to handle parallel
-- arrays with the existing machinery for constructor pattern
tidy1 _ (PArrPat pats ty)
tidy1 _ (PArrPat ty pats)
= return (idDsWrapper, unLoc parrConPat)
where
arity = length pats
parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty]
tidy1 _ (TuplePat pats boxity tys)
tidy1 _ (TuplePat tys pats boxity)
= return (idDsWrapper, unLoc tuple_ConPat)
where
arity = length pats
tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys
tidy1 _ (SumPat pat alt arity tys)
tidy1 _ (SumPat tys pat alt arity)
= return (idDsWrapper, unLoc sum_ConPat)
where
sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys
-- LitPats: we *might* be able to replace these w/ a simpler form
tidy1 _ (LitPat lit)
tidy1 _ (LitPat _ lit)
= return (idDsWrapper, tidyLitPat lit)
-- NPats: we *might* be able to replace these w/ a simpler form
tidy1 _ (NPat (L _ lit) mb_neg eq ty)
tidy1 _ (NPat ty (L _ lit) mb_neg eq)
= return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq ty)
-- Everything else goes through unchanged...
......@@ -484,13 +484,14 @@ tidy1 _ non_interesting_pat
tidy_bang_pat :: Id -> SrcSpan -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
-- Discard par/sig under a bang
tidy_bang_pat v _ (ParPat (L l p)) = tidy_bang_pat v l p
tidy_bang_pat v _ (SigPatOut (L l p) _) = tidy_bang_pat v l p
tidy_bang_pat v _ (ParPat _ (L l p)) = tidy_bang_pat v l p
tidy_bang_pat v _ (SigPat _ (L l p)) = tidy_bang_pat v l p
-- Push the bang-pattern inwards, in the hope that
-- it may disappear next time
tidy_bang_pat v l (AsPat v' p) = tidy1 v (AsPat v' (L l (BangPat p)))
tidy_bang_pat v l (CoPat w p t) = tidy1 v (CoPat w (BangPat (L l p)) t)
tidy_bang_pat v l (AsPat x v' p) = tidy1 v (AsPat x v' (L l (BangPat noExt p)))
tidy_bang_pat v l (CoPat x w p t)
= tidy1 v (CoPat x w (BangPat noExt (L l p)) t)
-- Discard bang around strict pattern
tidy_bang_pat v _ p@(LitPat {}) = tidy1 v p
......@@ -526,7 +527,7 @@ tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc)
--
-- NB: SigPatIn, ConPatIn should not happen
tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p))
tidy_bang_pat _ l p = return (idDsWrapper, BangPat noExt (L l p))
-------------------
push_bang_into_newtype_arg :: SrcSpan
......@@ -537,15 +538,16 @@ push_bang_into_newtype_arg :: SrcSpan
-- We are transforming !(N p) into (N !p)
push_bang_into_newtype_arg l _ty (PrefixCon (arg:args))
= ASSERT( null args)
PrefixCon [L l (BangPat arg)]
PrefixCon [L l (BangPat noExt arg)]
push_bang_into_newtype_arg l _ty (RecCon rf)
| HsRecFields { rec_flds = L lf fld : flds } <- rf
, HsRecField { hsRecFieldArg = arg } <- fld
= ASSERT( null flds)
RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg = L l (BangPat arg) })] })
RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg
= L l (BangPat noExt arg) })] })
push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})
| HsRecFields { rec_flds = [] } <- rf
= PrefixCon [L l (BangPat (noLoc (WildPat ty)))]
= PrefixCon [L l (BangPat noExt (noLoc (WildPat ty)))]
push_bang_into_newtype_arg _ _ cd
= pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)
......@@ -1071,7 +1073,7 @@ patGroup _ (ConPatOut { pat_con = L _ con
| PatSynCon psyn <- con = PgSyn psyn tys
patGroup _ (WildPat {}) = PgAny
patGroup _ (BangPat {}) = PgBang
patGroup _ (NPat (L _ OverLit {ol_val=oval}) mb_neg _ _) =
patGroup _ (NPat _ (L _ OverLit {ol_val=oval}) mb_neg _) =
case (oval, isJust mb_neg) of
(HsIntegral i, False) -> PgN (fromInteger (il_value i))
(HsIntegral i, True ) -> PgN (-fromInteger (il_value i))
......@@ -1079,14 +1081,15 @@ patGroup _ (NPat (L _ OverLit {ol_val=oval}) mb_neg _ _) =
(HsFractional r, True ) -> PgN (-fl_value r)
(HsIsString _ s, _) -> ASSERT(isNothing mb_neg)
PgOverS s
patGroup _ (NPlusKPat _ (L _ OverLit {ol_val=oval}) _ _ _ _) =
patGroup _ (NPlusKPat _ _ (L _ OverLit {ol_val=oval}) _ _ _) =
case oval of
HsIntegral i -> PgNpK (il_value i)
_ -> pprPanic "patGroup NPlusKPat" (ppr oval)
patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern
patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p))
patGroup _ (ListPat _ _ (Just _)) = PgOverloadedList
patGroup dflags (LitPat lit) = PgLit (hsLitKey dflags lit)
patGroup _ (CoPat _ _ p _) = PgCo (hsPatType p)
-- Type of innelexp pattern
patGroup _ (ViewPat _ expr p) = PgView expr (hsPatType (unLoc p))
patGroup _ (ListPat _ _ _ (Just _)) = PgOverloadedList
patGroup dflags (LitPat _ lit) = PgLit (hsLitKey dflags lit)
patGroup _ pat = pprPanic "patGroup" (ppr pat)
{-
......
......@@ -102,6 +102,8 @@ dsLit (HsRat _ (FL _ _ val) ty) = do
(head (tyConDataCons tycon), i_ty)
x -> pprPanic "dsLit" (ppr x)
dsLit (XLit x) = pprPanic "dsLit" (ppr x)
dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr
dsOverLit lit = do { dflags <- getDynFlags
; warnAboutOverflowedLiterals dflags lit
......@@ -110,12 +112,12 @@ dsOverLit lit = do { dflags <- getDynFlags
dsOverLit' :: DynFlags -> HsOverLit GhcTc -> DsM CoreExpr
-- Post-typechecker, the HsExpr field of an OverLit contains
-- (an expression for) the literal value itself
dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable
, ol_witness = witness, ol_type = ty })
dsOverLit' dflags (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty
, ol_witness = witness })
| not rebindable
, Just expr <- shortCutLit dflags val ty = dsExpr expr -- Note [Literal short cut]
| otherwise = dsExpr witness
dsOverLit' _ XOverLit{} = panic "dsOverLit'"
{-
Note [Literal short cut]
~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -246,7 +248,7 @@ getLHsIntegralLit (L _ (HsOverLit over_lit)) = getIntegralLit over_lit
getLHsIntegralLit _ = Nothing
getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name)
getIntegralLit (OverLit { ol_val = HsIntegral i, ol_type = ty })
getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty })
| Just tc <- tyConAppTyCon_maybe ty
= Just (il_value i, tyConName tc)
getIntegralLit _ = Nothing
......@@ -273,7 +275,7 @@ tidyLitPat (HsString src s)
(mkNilPat charTy) (unpackFS s)
-- The stringTy is the type of the whole pattern, not
-- the type to instantiate (:) or [] with!
tidyLitPat lit = LitPat lit
tidyLitPat lit = LitPat noExt lit
----------------
tidyNPat :: (HsLit GhcTc -> Pat GhcTc) -- How to tidy a LitPat
......@@ -284,7 +286,7 @@ tidyNPat :: (HsLit GhcTc -> Pat GhcTc) -- How to tidy a LitPat
-> HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc
-> Type
-> Pat GhcTc
tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty
tidyNPat tidy_lit_pat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty
-- False: Take short cuts only if the literal is not using rebindable syntax
--
-- Once that is settled, look for cases where the type of the
......@@ -313,7 +315,8 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty
type_change = not (outer_ty `eqType` ty)
mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc
mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] [])
mk_con_pat con lit
= unLoc (mkPrefixConPat con [noLoc $ LitPat noExt lit] [])
mb_int_lit :: Maybe Integer
mb_int_lit = case (mb_neg, val) of
......@@ -327,7 +330,7 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty
_ -> Nothing
tidyNPat _ over_lit mb_neg eq outer_ty
= NPat (noLoc over_lit) mb_neg eq outer_ty
= NPat outer_ty (noLoc over_lit) mb_neg eq
{-
************************************************************************
......@@ -361,7 +364,7 @@ matchLiterals (var:vars) ty sub_groups
match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
match_group eqns
= do dflags <- getDynFlags
let LitPat hs_lit = firstPat (head eqns)
let LitPat _ hs_lit = firstPat (head eqns)
match_result <- match vars ty (shiftEqns eqns)
return (hsLitKey dflags hs_lit, match_result)
......@@ -409,7 +412,7 @@ hsLitKey _ l = pprPanic "hsLitKey" (ppr l)
matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal
= do { let NPat (L _ lit) mb_neg eq_chk _ = firstPat eqn1
= do { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1
; lit_expr <- dsOverLit lit
; neg_lit <- case mb_neg of
Nothing -> return lit_expr
......@@ -440,7 +443,7 @@ We generate:
matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
-- All NPlusKPats, for the *same* literal k
matchNPlusKPats (var:vars) ty (eqn1:eqns)
= do { let NPlusKPat (L _ n1) (L _ lit1) lit2 ge minus _ = firstPat eqn1
= do { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus = firstPat eqn1
; lit1_expr <- dsOverLit lit1
; lit2_expr <- dsOverLit lit2
; pred_expr <- dsSyntaxExpr ge [Var var, lit1_expr]
......@@ -452,7 +455,7 @@ matchNPlusKPats (var:vars) ty (eqn1:eqns)
adjustMatchResult (foldr1 (.) wraps) $
match_result) }
where
shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ _ _ : pats })
shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats })
= (wrapBind n n1, eqn { eqn_pats = pats })
-- The wrapBind is a no-op for the first equation
shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
......