summaryrefslogtreecommitdiff
path: root/compiler/deSugar
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/deSugar')
-rw-r--r--compiler/deSugar/Check.hs61
-rw-r--r--compiler/deSugar/Coverage.hs214
-rw-r--r--compiler/deSugar/DsArrows.hs80
-rw-r--r--compiler/deSugar/DsExpr.hs124
-rw-r--r--compiler/deSugar/DsGRHSs.hs15
-rw-r--r--compiler/deSugar/DsListComp.hs20
-rw-r--r--compiler/deSugar/DsMeta.hs194
-rw-r--r--compiler/deSugar/DsUtils.hs63
-rw-r--r--compiler/deSugar/Match.hs107
-rw-r--r--compiler/deSugar/MatchLit.hs35
-rw-r--r--compiler/deSugar/PmExpr.hs39
11 files changed, 497 insertions, 455 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index 22af2fb9d0..6372967cc0 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -690,12 +690,12 @@ truePattern = nullaryConPattern (RealDataCon trueDataCon)
-- | A fake guard pattern (True <- _) used to represent cases we cannot handle
fake_pat :: Pattern
fake_pat = PmGrd { pm_grd_pv = [truePattern]
- , pm_grd_expr = PmExprOther EWildPat }
+ , pm_grd_expr = PmExprOther (EWildPat noExt) }
{-# INLINE fake_pat #-}
-- | Check whether a guard pattern is generated by the checker (unhandled)
isFakeGuard :: [Pattern] -> PmExpr -> Bool
-isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther EWildPat)
+isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther (EWildPat _))
| c == trueDataCon = True
| otherwise = False
isFakeGuard _pats _e = False
@@ -738,25 +738,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
@@ -766,26 +766,26 @@ 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
True -> do
(xp,xe) <- mkPmId2Forms arg_ty
- let g = mkGuard ps (HsApp lexpr xe)
+ let g = mkGuard ps (HsApp noExt lexpr xe)
return [xp,g]
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
@@ -794,7 +794,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
@@ -814,26 +814,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]
@@ -842,23 +843,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))
@@ -1231,7 +1232,7 @@ mkPmId ty = getUniqueM >>= \unique ->
mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr GhcTc)
mkPmId2Forms ty = do
x <- mkPmId ty
- return (PmVar x, noLoc (HsVar (noLoc x)))
+ return (PmVar x, noLoc (HsVar noExt (noLoc x)))
-- ----------------------------------------------------------------------------
-- * Converting between Value Abstractions, Patterns and PmExpr
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index b3534206ff..1f84114726 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -451,15 +451,15 @@ addTickLHsExprNever (L pos e0) = do
-- general heuristic: expressions which do not denote values are good
-- break points
isGoodBreakExpr :: HsExpr GhcTc -> Bool
-isGoodBreakExpr (HsApp {}) = True
-isGoodBreakExpr (HsAppTypeOut {}) = True
-isGoodBreakExpr (OpApp {}) = True
-isGoodBreakExpr _other = False
+isGoodBreakExpr (HsApp {}) = True
+isGoodBreakExpr (HsAppType {}) = True
+isGoodBreakExpr (OpApp {}) = True
+isGoodBreakExpr _other = False
isCallSite :: HsExpr GhcTc -> Bool
-isCallSite HsApp{} = True
-isCallSite HsAppTypeOut{} = True
-isCallSite OpApp{} = True
+isCallSite HsApp{} = True
+isCallSite HsAppType{} = True
+isCallSite OpApp{} = True
isCallSite _ = False
addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
@@ -481,55 +481,58 @@ addBinTickLHsExpr boxLabel (L pos e0)
-- in the addTickLHsExpr family of functions.)
addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)
-addTickHsExpr e@(HsVar (L _ id)) = do freeVar id; return e
-addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar"
-addTickHsExpr e@(HsConLikeOut con)
+addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e
+addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar"
+addTickHsExpr e@(HsConLikeOut _ con)
| Just id <- conLikeWrapId_maybe con = do freeVar id; return e
-addTickHsExpr e@(HsIPVar _) = return e
-addTickHsExpr e@(HsOverLit _) = return e
-addTickHsExpr e@(HsOverLabel{}) = return e
-addTickHsExpr e@(HsLit _) = return e
-addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup)
-addTickHsExpr (HsLamCase mgs) = liftM HsLamCase (addTickMatchGroup True mgs)
-addTickHsExpr (HsApp e1 e2) = liftM2 HsApp (addTickLHsExprNever e1)
- (addTickLHsExpr e2)
-addTickHsExpr (HsAppTypeOut e ty) = liftM2 HsAppTypeOut (addTickLHsExprNever e)
- (return ty)
-
-addTickHsExpr (OpApp e1 e2 fix e3) =
+addTickHsExpr e@(HsIPVar {}) = return e
+addTickHsExpr e@(HsOverLit {}) = return e
+addTickHsExpr e@(HsOverLabel{}) = return e
+addTickHsExpr e@(HsLit {}) = return e
+addTickHsExpr (HsLam x matchgroup) = liftM (HsLam x)
+ (addTickMatchGroup True matchgroup)
+addTickHsExpr (HsLamCase x mgs) = liftM (HsLamCase x)
+ (addTickMatchGroup True mgs)
+addTickHsExpr (HsApp x e1 e2) = liftM2 (HsApp x) (addTickLHsExprNever e1)
+ (addTickLHsExpr e2)
+addTickHsExpr (HsAppType ty e) = liftM2 HsAppType (return ty)
+ (addTickLHsExprNever e)
+
+
+addTickHsExpr (OpApp fix e1 e2 e3) =
liftM4 OpApp
+ (return fix)
(addTickLHsExpr e1)
(addTickLHsExprNever e2)
- (return fix)
(addTickLHsExpr e3)
-addTickHsExpr (NegApp e neg) =
- liftM2 NegApp
+addTickHsExpr (NegApp x e neg) =
+ liftM2 (NegApp x)
(addTickLHsExpr e)
(addTickSyntaxExpr hpcSrcSpan neg)
-addTickHsExpr (HsPar e) =
- liftM HsPar (addTickLHsExprEvalInner e)
-addTickHsExpr (SectionL e1 e2) =
- liftM2 SectionL
+addTickHsExpr (HsPar x e) =
+ liftM (HsPar x) (addTickLHsExprEvalInner e)
+addTickHsExpr (SectionL x e1 e2) =
+ liftM2 (SectionL x)
(addTickLHsExpr e1)
(addTickLHsExprNever e2)
-addTickHsExpr (SectionR e1 e2) =
- liftM2 SectionR
+addTickHsExpr (SectionR x e1 e2) =
+ liftM2 (SectionR x)
(addTickLHsExprNever e1)
(addTickLHsExpr e2)
-addTickHsExpr (ExplicitTuple es boxity) =
- liftM2 ExplicitTuple
+addTickHsExpr (ExplicitTuple x es boxity) =
+ liftM2 (ExplicitTuple x)
(mapM addTickTupArg es)
(return boxity)
-addTickHsExpr (ExplicitSum tag arity e ty) = do
+addTickHsExpr (ExplicitSum ty tag arity e) = do
e' <- addTickLHsExpr e
- return (ExplicitSum tag arity e' ty)
-addTickHsExpr (HsCase e mgs) =
- liftM2 HsCase
+ return (ExplicitSum ty tag arity e')
+addTickHsExpr (HsCase x e mgs) =
+ liftM2 (HsCase x)
(addTickLHsExpr e) -- not an EvalInner; e might not necessarily
-- be evaluated.
(addTickMatchGroup False mgs)
-addTickHsExpr (HsIf cnd e1 e2 e3) =
- liftM3 (HsIf cnd)
+addTickHsExpr (HsIf x cnd e1 e2 e3) =
+ liftM3 (HsIf x cnd)
(addBinTickLHsExpr (BinBox CondBinBox) e1)
(addTickLHsExprOptAlt True e2)
(addTickLHsExprOptAlt True e3)
@@ -537,14 +540,14 @@ addTickHsExpr (HsMultiIf ty alts)
= do { let isOneOfMany = case alts of [_] -> False; _ -> True
; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts
; return $ HsMultiIf ty alts' }
-addTickHsExpr (HsLet (L l binds) e) =
+addTickHsExpr (HsLet x (L l binds) e) =
bindLocals (collectLocalBinders binds) $
- liftM2 (HsLet . L l)
+ liftM2 (HsLet x . L l)
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsExprLetBody e)
-addTickHsExpr (HsDo cxt (L l stmts) srcloc)
+addTickHsExpr (HsDo srcloc cxt (L l stmts))
= do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
- ; return (HsDo cxt (L l stmts') srcloc) }
+ ; return (HsDo srcloc cxt (L l stmts')) }
where
forQual = case cxt of
ListComp -> Just $ BinBox QualBinBox
@@ -574,12 +577,12 @@ addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })
; flds' <- mapM addTickHsRecField flds
; return (expr { rupd_expr = e', rupd_flds = flds' }) }
-addTickHsExpr (ExprWithTySig e ty) =
+addTickHsExpr (ExprWithTySig ty e) =
liftM2 ExprWithTySig
- (addTickLHsExprNever e) -- No need to tick the inner expression
- -- for expressions with signatures
(return ty)
-addTickHsExpr (ArithSeq ty wit arith_seq) =
+ (addTickLHsExprNever e) -- No need to tick the inner expression
+ -- for expressions with signatures
+addTickHsExpr (ArithSeq ty wit arith_seq) =
liftM3 ArithSeq
(return ty)
(addTickWit wit)
@@ -589,26 +592,26 @@ addTickHsExpr (ArithSeq ty wit arith_seq) =
return (Just fl')
-- We might encounter existing ticks (multiple Coverage passes)
-addTickHsExpr (HsTick t e) =
- liftM (HsTick t) (addTickLHsExprNever e)
-addTickHsExpr (HsBinTick t0 t1 e) =
- liftM (HsBinTick t0 t1) (addTickLHsExprNever e)
+addTickHsExpr (HsTick x t e) =
+ liftM (HsTick x t) (addTickLHsExprNever e)
+addTickHsExpr (HsBinTick x t0 t1 e) =
+ liftM (HsBinTick x t0 t1) (addTickLHsExprNever e)
-addTickHsExpr (HsTickPragma _ _ _ (L pos e0)) = do
+addTickHsExpr (HsTickPragma _ _ _ _ (L pos e0)) = do
e2 <- allocTickBox (ExpBox False) False False pos $
addTickHsExpr e0
return $ unLoc e2
-addTickHsExpr (PArrSeq ty arith_seq) =
+addTickHsExpr (PArrSeq ty arith_seq) =
liftM2 PArrSeq
(return ty)
(addTickArithSeqInfo arith_seq)
-addTickHsExpr (HsSCC src nm e) =
- liftM3 HsSCC
+addTickHsExpr (HsSCC x src nm e) =
+ liftM3 (HsSCC x)
(return src)
(return nm)
(addTickLHsExpr e)
-addTickHsExpr (HsCoreAnn src nm e) =
- liftM3 HsCoreAnn
+addTickHsExpr (HsCoreAnn x src nm e) =
+ liftM3 (HsCoreAnn x)
(return src)
(return nm)
(addTickLHsExpr e)
@@ -616,27 +619,23 @@ addTickHsExpr e@(HsBracket {}) = return e
addTickHsExpr e@(HsTcBracketOut {}) = return e
addTickHsExpr e@(HsRnBracketOut {}) = return e
addTickHsExpr e@(HsSpliceE {}) = return e
-addTickHsExpr (HsProc pat cmdtop) =
- liftM2 HsProc
+addTickHsExpr (HsProc x pat cmdtop) =
+ liftM2 (HsProc x)
(addTickLPat pat)
(liftL (addTickHsCmdTop) cmdtop)
-addTickHsExpr (HsWrap w e) =
- liftM2 HsWrap
+addTickHsExpr (HsWrap x w e) =
+ liftM2 (HsWrap x)
(return w)
(addTickHsExpr e) -- Explicitly no tick on inside
-addTickHsExpr (ExprWithTySigOut e ty) =
- liftM2 ExprWithTySigOut
- (addTickLHsExprNever e) -- No need to tick the inner expression
- (return ty) -- for expressions with signatures
-
-- Others should never happen in expression content.
addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e)
addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
-addTickTupArg (L l (Present e)) = do { e' <- addTickLHsExpr e
- ; return (L l (Present e')) }
+addTickTupArg (L l (Present x e)) = do { e' <- addTickLHsExpr e
+ ; return (L l (Present x e')) }
addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))
+addTickTupArg (L _ (XTupArg _)) = panic "addTickTupArg"
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
-> TM (MatchGroup GhcTc (LHsExpr GhcTc))
@@ -772,11 +771,12 @@ addTickApplicativeArg isGuard (op, arg) =
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
-> TM (ParStmtBlock GhcTc GhcTc)
-addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) =
- liftM3 ParStmtBlock
+addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) =
+ liftM3 (ParStmtBlock x)
(addTickLStmts isGuard stmts)
(return ids)
(addTickSyntaxExpr hpcSrcSpan returnExpr)
+addTickStmtAndBinders _ (XParStmtBlock{}) = panic "addTickStmtAndBinders"
addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
addTickHsLocalBinds (HsValBinds binds) =
@@ -787,15 +787,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)
@@ -820,12 +822,11 @@ addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)
addTickLPat pat = return pat
addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)
-addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
- liftM4 HsCmdTop
+addTickHsCmdTop (HsCmdTop x cmd) =
+ liftM2 HsCmdTop
+ (return x)
(addTickLHsCmd cmd)
- (return tys)
- (return ty)
- (return syntaxtable)
+addTickHsCmdTop (XCmdTop{}) = panic "addTickHsCmdTop"
addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd (L pos c0) = do
@@ -833,10 +834,10 @@ addTickLHsCmd (L pos c0) = do
return $ L pos c1
addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)
-addTickHsCmd (HsCmdLam matchgroup) =
- liftM HsCmdLam (addTickCmdMatchGroup matchgroup)
-addTickHsCmd (HsCmdApp c e) =
- liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e)
+addTickHsCmd (HsCmdLam x matchgroup) =
+ liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup)
+addTickHsCmd (HsCmdApp x c e) =
+ liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e)
{-
addTickHsCmd (OpApp e1 c2 fix c3) =
liftM4 OpApp
@@ -845,41 +846,43 @@ addTickHsCmd (OpApp e1 c2 fix c3) =
(return fix)
(addTickLHsCmd c3)
-}
-addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e)
-addTickHsCmd (HsCmdCase e mgs) =
- liftM2 HsCmdCase
+addTickHsCmd (HsCmdPar x e) = liftM (HsCmdPar x) (addTickLHsCmd e)
+addTickHsCmd (HsCmdCase x e mgs) =
+ liftM2 (HsCmdCase x)
(addTickLHsExpr e)
(addTickCmdMatchGroup mgs)
-addTickHsCmd (HsCmdIf cnd e1 c2 c3) =
- liftM3 (HsCmdIf cnd)
+addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =
+ liftM3 (HsCmdIf x cnd)
(addBinTickLHsExpr (BinBox CondBinBox) e1)
(addTickLHsCmd c2)
(addTickLHsCmd c3)
-addTickHsCmd (HsCmdLet (L l binds) c) =
+addTickHsCmd (HsCmdLet x (L l binds) c) =
bindLocals (collectLocalBinders binds) $
- liftM2 (HsCmdLet . L l)
+ liftM2 (HsCmdLet x . L l)
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsCmd c)
-addTickHsCmd (HsCmdDo (L l stmts) srcloc)
+addTickHsCmd (HsCmdDo srcloc (L l stmts))
= do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
- ; return (HsCmdDo (L l stmts') srcloc) }
+ ; return (HsCmdDo srcloc (L l stmts')) }
-addTickHsCmd (HsCmdArrApp e1 e2 ty1 arr_ty lr) =
+addTickHsCmd (HsCmdArrApp arr_ty e1 e2 ty1 lr) =
liftM5 HsCmdArrApp
+ (return arr_ty)
(addTickLHsExpr e1)
(addTickLHsExpr e2)
(return ty1)
- (return arr_ty)
(return lr)
-addTickHsCmd (HsCmdArrForm e f fix cmdtop) =
- liftM4 HsCmdArrForm
+addTickHsCmd (HsCmdArrForm x e f fix cmdtop) =
+ liftM4 (HsCmdArrForm x)
(addTickLHsExpr e)
(return f)
(return fix)
(mapM (liftL (addTickHsCmdTop)) cmdtop)
-addTickHsCmd (HsCmdWrap w cmd)
- = liftM2 HsCmdWrap (return w) (addTickHsCmd cmd)
+addTickHsCmd (HsCmdWrap x w cmd)
+ = liftM2 (HsCmdWrap x) (return w) (addTickHsCmd cmd)
+
+addTickHsCmd e@(XCmd {}) = pprPanic "addTickHsCmd" (ppr e)
-- Others should never happen in a command context.
--addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e)
@@ -1160,7 +1163,7 @@ allocTickBox boxLabel countEntries topOnly pos m =
(fvs, e) <- getFreeVars m
env <- getEnv
tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
- return (L pos (HsTick tickish (L pos e)))
+ return (L pos (HsTick noExt tickish (L pos e)))
) (do
e <- m
return (L pos e)
@@ -1247,13 +1250,14 @@ mkBinTickBoxHpc boxLabel pos e =
c = tickBoxCount st
mes = mixEntries st
in
- ( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) e
- -- notice that F and T are reversed,
- -- because we are building the list in
- -- reverse...
- , noFVs
- , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
- )
+ ( L pos $ HsTick noExt (HpcTick (this_mod env) c)
+ $ L pos $ HsBinTick noExt (c+1) (c+2) e
+ -- notice that F and T are reversed,
+ -- because we are building the list in
+ -- reverse...
+ , noFVs
+ , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
+ )
mkHpcPos :: SrcSpan -> HpcPos
mkHpcPos pos@(RealSrcSpan s)
diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs
index 24d7d8a61c..61dc7c5b5b 100644
--- a/compiler/deSugar/DsArrows.hs
+++ b/compiler/deSugar/DsArrows.hs
@@ -313,7 +313,7 @@ dsProcExpr
:: LPat GhcTc
-> LHsCmdTop GhcTc
-> DsM CoreExpr
-dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do
+dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do
(meth_binds, meth_ids) <- mkCmdEnv ids
let locals = mkVarSet (collectPatBinders pat)
(core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals unitTy cmd_ty cmd
@@ -328,6 +328,7 @@ dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do
(Lam var match_code)
core_cmd
return (mkLets meth_binds proc_code)
+dsProcExpr _ (L _ XCmdTop{}) = panic "dsProcExpr"
{-
Translation of a command judgement of the form
@@ -363,7 +364,7 @@ dsCmd :: DsCmdEnv -- arrow combinators
-- ---> premap (\ ((xs), _stk) -> arg) fun
dsCmd ids local_vars stack_ty res_ty
- (HsCmdArrApp arrow arg arrow_ty HsFirstOrderApp _)
+ (HsCmdArrApp arrow_ty arrow arg HsFirstOrderApp _)
env_ids = do
let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
@@ -388,7 +389,7 @@ dsCmd ids local_vars stack_ty res_ty
-- ---> premap (\ ((xs), _stk) -> (fun, arg)) app
dsCmd ids local_vars stack_ty res_ty
- (HsCmdArrApp arrow arg arrow_ty HsHigherOrderApp _)
+ (HsCmdArrApp arrow_ty arrow arg HsHigherOrderApp _)
env_ids = do
let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
@@ -416,7 +417,7 @@ dsCmd ids local_vars stack_ty res_ty
--
-- ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd
-dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do
+dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do
core_arg <- dsLExpr arg
let
arg_ty = exprType core_arg
@@ -449,7 +450,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do
-- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd
dsCmd ids local_vars stack_ty res_ty
- (HsCmdLam (MG { mg_alts = L _ [L _ (Match { m_pats = pats
+ (HsCmdLam _ (MG { mg_alts = L _ [L _ (Match { m_pats = pats
, m_grhss = GRHSs [L _ (GRHS [] body)] _ })] }))
env_ids = do
let pat_vars = mkVarSet (collectPatsBinders pats)
@@ -479,7 +480,7 @@ dsCmd ids local_vars stack_ty res_ty
return (do_premap ids in_ty in_ty' res_ty select_code core_body,
free_vars `udfmMinusUFM` getUniqSet pat_vars)
-dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids
+dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ cmd) env_ids
= dsLCmd ids local_vars stack_ty res_ty cmd env_ids
-- D, xs |- e :: Bool
@@ -492,7 +493,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids
-- if e then Left ((xs1),stk) else Right ((xs2),stk))
-- (c1 ||| c2)
-dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)
+dsCmd ids local_vars stack_ty res_ty (HsCmdIf _ mb_fun cond then_cmd else_cmd)
env_ids = do
core_cond <- dsLExpr cond
(core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack_ty res_ty then_cmd
@@ -553,8 +554,8 @@ case bodies, containing the following fields:
-}
dsCmd ids local_vars stack_ty res_ty
- (HsCmdCase exp (MG { mg_alts = L l matches, mg_arg_tys = arg_tys
- , mg_origin = origin }))
+ (HsCmdCase _ exp (MG { mg_alts = L l matches, mg_arg_tys = arg_tys
+ , mg_origin = origin }))
env_ids = do
stack_id <- newSysLocalDs stack_ty
@@ -575,10 +576,12 @@ dsCmd ids local_vars stack_ty res_ty
left_con <- dsLookupDataCon leftDataConName
right_con <- dsLookupDataCon rightDataConName
let
- left_id = HsConLikeOut (RealDataCon left_con)
- right_id = HsConLikeOut (RealDataCon right_con)
- left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
- right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e
+ left_id = HsConLikeOut noExt (RealDataCon left_con)
+ right_id = HsConLikeOut noExt (RealDataCon right_con)
+ left_expr ty1 ty2 e = noLoc $ HsApp noExt
+ (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
+ right_expr ty1 ty2 e = noLoc $ HsApp noExt
+ (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e
-- Prefix each tuple with a distinct series of Left's and Right's,
-- in a balanced way, keeping track of the types.
@@ -597,9 +600,10 @@ dsCmd ids local_vars stack_ty res_ty
(_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
in_ty = envStackType env_ids stack_ty
- core_body <- dsExpr (HsCase exp (MG { mg_alts = L l matches'
- , mg_arg_tys = arg_tys
- , mg_res_ty = sum_ty, mg_origin = origin }))
+ core_body <- dsExpr (HsCase noExt exp
+ (MG { mg_alts = L l matches'
+ , mg_arg_tys = arg_tys
+ , mg_res_ty = sum_ty, mg_origin = origin }))
-- Note that we replace the HsCase result type by sum_ty,
-- which is the type of matches'
@@ -613,7 +617,8 @@ dsCmd ids local_vars stack_ty res_ty
--
-- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c
-dsCmd ids local_vars stack_ty res_ty (HsCmdLet lbinds@(L _ binds) body) env_ids = do
+dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body)
+ env_ids = do
let
defined_vars = mkVarSet (collectLocalBinders binds)
local_vars' = defined_vars `unionVarSet` local_vars
@@ -638,7 +643,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet lbinds@(L _ binds) body) env_ids
--
-- ---> premap (\ (env,stk) -> env) c
-dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo (L loc stmts) stmts_ty) env_ids = do
+dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty (L loc stmts))
+ env_ids = do
putSrcSpanDs loc $
dsNoLevPoly stmts_ty
(text "In the do-command:" <+> ppr do_block)
@@ -658,14 +664,14 @@ dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo (L loc stmts) stmts_ty) e
-- -----------------------------------
-- D; xs |-a (|e c1 ... cn|) :: stk --> t ---> e [t_xs] c1 ... cn
-dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ _ args) env_ids = do
+dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do
let env_ty = mkBigCoreVarTupTy env_ids
core_op <- dsLExpr op
(core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args
return (mkApps (App core_op (Type env_ty)) core_args,
unionDVarSets fv_sets)
-dsCmd ids local_vars stack_ty res_ty (HsCmdWrap wrap cmd) env_ids = do
+dsCmd ids local_vars stack_ty res_ty (HsCmdWrap _ wrap cmd) env_ids = do
(core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids
core_wrap <- dsHsWrapper wrap
return (core_wrap core_cmd, env_ids')
@@ -682,7 +688,8 @@ dsTrimCmdArg
-> LHsCmdTop GhcTc -- command argument to desugar
-> DsM (CoreExpr, -- desugared expression
DIdSet) -- subset of local vars that occur free
-dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do
+dsTrimCmdArg local_vars env_ids
+ (L _ (HsCmdTop (CmdTopTc stack_ty cmd_ty ids) cmd )) = do
(meth_binds, meth_ids) <- mkCmdEnv ids
(core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd
stack_id <- newSysLocalDs stack_ty
@@ -693,6 +700,7 @@ dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do
arg_code = if env_ids' == env_ids then core_cmd else
do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd
return (mkLets meth_binds arg_code, free_vars)
+dsTrimCmdArg _ _ (L _ XCmdTop{}) = panic "dsTrimCmdArg"
-- Given D; xs |-a c : stk --> t, builds c with xs fed back.
-- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk))
@@ -1187,31 +1195,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
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 392baccd38..0eb5c0e376 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -79,8 +79,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
@@ -251,17 +252,17 @@ dsExpr = ds_expr False
ds_expr :: Bool -- are we directly inside an HsWrap?
-- See Wrinkle in Note [Detecting forced eta expansion]
-> HsExpr GhcTc -> DsM CoreExpr
-ds_expr _ (HsPar e) = dsLExpr e
-ds_expr _ (ExprWithTySigOut e _) = dsLExpr e
-ds_expr w (HsVar (L _ var)) = dsHsVar w var
+ds_expr _ (HsPar _ e) = dsLExpr e
+ds_expr _ (ExprWithTySig _ e) = dsLExpr e
+ds_expr w (HsVar _ (L _ var)) = dsHsVar w var
ds_expr _ (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
-ds_expr w (HsConLikeOut con) = dsConLike w con
-ds_expr _ (HsIPVar _) = panic "dsExpr: HsIPVar"
+ds_expr w (HsConLikeOut _ con) = dsConLike w con
+ds_expr _ (HsIPVar {}) = panic "dsExpr: HsIPVar"
ds_expr _ (HsOverLabel{}) = panic "dsExpr: HsOverLabel"
-ds_expr _ (HsLit lit) = dsLit (convertLit lit)
-ds_expr _ (HsOverLit lit) = dsOverLit lit
+ds_expr _ (HsLit _ lit) = dsLit (convertLit lit)
+ds_expr _ (HsOverLit _ lit) = dsOverLit lit
-ds_expr _ (HsWrap co_fn e)
+ds_expr _ (HsWrap _ co_fn e)
= do { e' <- ds_expr True e -- This is the one place where we recurse to
-- ds_expr (passing True), rather than dsExpr
; wrap' <- dsHsWrapper co_fn
@@ -272,7 +273,7 @@ ds_expr _ (HsWrap co_fn e)
; warnAboutIdentities dflags e' wrapped_ty
; return wrapped_e }
-ds_expr _ (NegApp (L loc (HsOverLit lit@(OverLit { ol_val = HsIntegral i })))
+ds_expr _ (NegApp _ (L loc (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))
neg_expr)
= do { expr' <- putSrcSpanDs loc $ do
{ dflags <- getDynFlags
@@ -281,27 +282,26 @@ ds_expr _ (NegApp (L loc (HsOverLit lit@(OverLit { ol_val = HsIntegral i })))
; dsOverLit' dflags lit }
; dsSyntaxExpr neg_expr [expr'] }
-ds_expr _ (NegApp expr neg_expr)
+ds_expr _ (NegApp _ expr neg_expr)
= do { expr' <- dsLExpr expr
; dsSyntaxExpr neg_expr [expr'] }
-ds_expr _ (HsLam a_Match)
+ds_expr _ (HsLam _ a_Match)
= uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match
-ds_expr _ (HsLamCase matches)
+ds_expr _ (HsLamCase _ matches)
= do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
; return $ Lam discrim_var matching_code }
-ds_expr _ e@(HsApp fun arg)
+ds_expr _ e@(HsApp _ fun arg)
= do { fun' <- dsLExpr fun
; dsWhenNoErrs (dsLExprNoLP arg)
(\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') }
-ds_expr _ (HsAppTypeOut e _)
+ds_expr _ (HsAppType _ e)
-- ignore type arguments here; they're in the wrappers instead at this point
= dsLExpr e
-
{-
Note [Desugaring vars]
~~~~~~~~~~~~~~~~~~~~~~
@@ -341,19 +341,19 @@ If \tr{expr} is actually just a variable, say, then the simplifier
will sort it out.
-}
-ds_expr _ e@(OpApp e1 op _ e2)
+ds_expr _ e@(OpApp _ e1 op e2)
= -- for the type of y, we need the type of op's 2nd argument
do { op' <- dsLExpr op
; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2])
(\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') }
-ds_expr _ (SectionL expr op) -- Desugar (e !) to ((!) e)
+ds_expr _ (SectionL _ expr op) -- Desugar (e !) to ((!) e)
= do { op' <- dsLExpr op
; dsWhenNoErrs (dsLExprNoLP expr)
(\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') }
-- dsLExpr (SectionR op expr) -- \ x -> op x expr
-ds_expr _ e@(SectionR op expr) = do
+ds_expr _ e@(SectionR _ op expr) = do
core_op <- dsLExpr op
-- for the type of x, we need the type of op's 2nd argument
let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
@@ -364,31 +364,32 @@ ds_expr _ e@(SectionR op expr) = do
Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e)
core_op [Var x_id, Var y_id]))
-ds_expr _ (ExplicitTuple tup_args boxity)
+ds_expr _ (ExplicitTuple _ tup_args boxity)
= do { let go (lam_vars, args) (L _ (Missing ty))
-- For every missing expression, we need
-- another lambda in the desugaring.
= do { lam_var <- newSysLocalDsNoLP ty
; return (lam_var : lam_vars, Var lam_var : args) }
- go (lam_vars, args) (L _ (Present expr))
+ go (lam_vars, args) (L _ (Present _ expr))
-- Expressions that are present don't generate
-- lambdas, just arguments.
= do { core_expr <- dsLExprNoLP expr
; return (lam_vars, core_expr : args) }
+ go _ (L _ (XTupArg {})) = panic "ds_expr"
; dsWhenNoErrs (foldM go ([], []) (reverse tup_args))
-- The reverse is because foldM goes left-to-right
(\(lam_vars, args) -> mkCoreLams lam_vars $
mkCoreTupBoxity boxity args) }
-ds_expr _ (ExplicitSum alt arity expr types)
+ds_expr _ (ExplicitSum types alt arity expr)
= do { dsWhenNoErrs (dsLExprNoLP expr)
(\core_expr -> mkCoreConApps (sumDataCon alt arity)
(map (Type . getRuntimeRep) types ++
map Type types ++
[core_expr]) ) }
-ds_expr _ (HsSCC _ cc expr@(L loc _)) = do
+ds_expr _ (HsSCC _ _ cc expr@(L loc _)) = do
dflags <- getDynFlags
if gopt Opt_SccProfilingOn dflags
then do
@@ -400,31 +401,31 @@ ds_expr _ (HsSCC _ cc expr@(L loc _)) = do
<$> dsLExpr expr
else dsLExpr expr
-ds_expr _ (HsCoreAnn _ _ expr)
+ds_expr _ (HsCoreAnn _ _ _ expr)
= dsLExpr expr
-ds_expr _ (HsCase discrim matches)
+ds_expr _ (HsCase _ discrim matches)
= do { core_discrim <- dsLExpr discrim
; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches
; return (bindNonRec discrim_var core_discrim matching_code) }
-- Pepe: The binds are in scope in the body but NOT in the binding group
-- This is to avoid silliness in breakpoints
-ds_expr _ (HsLet binds body) = do
+ds_expr _ (HsLet _ binds body) = do
body' <- dsLExpr body
dsLocalBinds binds body'
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
-- because the interpretation of `stmts' depends on what sort of thing it is.
--
-ds_expr _ (HsDo ListComp (L _ stmts) res_ty) = dsListComp stmts res_ty
-ds_expr _ (HsDo PArrComp (L _ stmts) _) = dsPArrComp (map unLoc stmts)
-ds_expr _ (HsDo DoExpr (L _ stmts) _) = dsDo stmts
-ds_expr _ (HsDo GhciStmtCtxt (L _ stmts) _) = dsDo stmts
-ds_expr _ (HsDo MDoExpr (L _ stmts) _) = dsDo stmts
-ds_expr _ (HsDo MonadComp (L _ stmts) _) = dsMonadComp stmts
-
-ds_expr _ (HsIf mb_fun guard_expr then_expr else_expr)
+ds_expr _ (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty
+ds_expr _ (HsDo _ PArrComp (L _ stmts)) = dsPArrComp (map unLoc stmts)
+ds_expr _ (HsDo _ DoExpr (L _ stmts)) = dsDo stmts
+ds_expr _ (HsDo _ GhciStmtCtxt (L _ stmts)) = dsDo stmts
+ds_expr _ (HsDo _ MDoExpr (L _ stmts)) = dsDo stmts
+ds_expr _ (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts
+
+ds_expr _ (HsIf _ mb_fun guard_expr then_expr else_expr)
= do { pred <- dsLExpr guard_expr
; b1 <- dsLExpr then_expr
; b2 <- dsLExpr else_expr
@@ -458,7 +459,7 @@ ds_expr _ (ExplicitList elt_ty wit xs)
-- We desugar [:x1, ..., xn:] as
-- singletonP x1 +:+ ... +:+ singletonP xn
--
-ds_expr _ (ExplicitPArr ty []) = do
+ds_expr _ (ExplicitPArr ty []) = do
emptyP <- dsDPHBuiltin emptyPVar
return (Var emptyP `App` Type ty)
ds_expr _ (ExplicitPArr ty xs) = do
@@ -540,8 +541,9 @@ We also handle @C{}@ as valid construction syntax for an unlabelled
constructor @C@, setting all of @C@'s fields to bottom.
-}
-ds_expr _ (RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds
- , rcon_con_like = con_like })
+ds_expr _ (RecordCon { rcon_flds = rbinds
+ , rcon_ext = RecordConTc { rcon_con_expr = con_expr
+ , rcon_con_like = con_like }})
= do { con_expr' <- dsExpr con_expr
; let
(arg_tys, _) = tcSplitFunTys (exprType con_expr')
@@ -600,9 +602,11 @@ So we need to cast (T a Int) to (T a b). Sigh.
-}
ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
- , rupd_cons = cons_to_upd
- , rupd_in_tys = in_inst_tys, rupd_out_tys = out_inst_tys
- , rupd_wrap = dict_req_wrap } )
+ , rupd_ext = RecordUpdTc
+ { rupd_cons = cons_to_upd
+ , rupd_in_tys = in_inst_tys
+ , rupd_out_tys = out_inst_tys
+ , rupd_wrap = dict_req_wrap }} )
| null fields
= dsLExpr record_expr
| otherwise
@@ -666,7 +670,7 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
mk_val_arg fl pat_arg_id
= nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id)
- inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut con)
+ inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExt con)
-- Reconstruct with the WrapId so that unpacking happens
-- The order here is because of the order in `TcPatSyn`.
wrap = mkWpEvVarApps theta_vars <.>
@@ -718,16 +722,16 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
-- Template Haskell stuff
-ds_expr _ (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut"
-ds_expr _ (HsTcBracketOut x ps) = dsBracket x ps
-ds_expr _ (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s)
+ds_expr _ (HsRnBracketOut _ _ _) = panic "dsExpr HsRnBracketOut"
+ds_expr _ (HsTcBracketOut _ x ps) = dsBracket x ps
+ds_expr _ (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s)
-- Arrow notation extension
-ds_expr _ (HsProc pat cmd) = dsProcExpr pat cmd
+ds_expr _ (HsProc _ pat cmd) = dsProcExpr pat cmd
-- Hpc Support
-ds_expr _ (HsTick tickish e) = do
+ds_expr _ (HsTick _ tickish e) = do
e' <- dsLExpr e
return (Tick tickish e')
@@ -738,20 +742,19 @@ ds_expr _ (HsTick tickish e) = do
-- (did you go here: YES or NO), but will effect accurate
-- tick counting.
-ds_expr _ (HsBinTick ixT ixF e) = do
+ds_expr _ (HsBinTick _ ixT ixF e) = do
e2 <- dsLExpr e
do { ASSERT(exprType e2 `eqType` boolTy)
mkBinaryTickBox ixT ixF e2
}
-ds_expr _ (HsTickPragma _ _ _ expr) = do
+ds_expr _ (HsTickPragma _ _ _ _ expr) = do
dflags <- getDynFlags
if gopt Opt_Hpc dflags
then panic "dsExpr:HsTickPragma"
else dsLExpr expr
-- HsSyn constructs that just shouldn't be here:
-ds_expr _ (ExprWithTySig {}) = panic "dsExpr:ExprWithTySig"
ds_expr _ (HsBracket {}) = panic "dsExpr:HsBracket"
ds_expr _ (HsArrApp {}) = panic "dsExpr:HsArrApp"
ds_expr _ (HsArrForm {}) = panic "dsExpr:HsArrForm"
@@ -759,9 +762,10 @@ ds_expr _ (EWildPat {}) = panic "dsExpr:EWildPat"
ds_expr _ (EAsPat {}) = panic "dsExpr:EAsPat"
ds_expr _ (EViewPat {}) = panic "dsExpr:EViewPat"
ds_expr _ (ELazyPat {}) = panic "dsExpr:ELazyPat"
-ds_expr _ (HsAppType {}) = panic "dsExpr:HsAppType" -- removed by typechecker
ds_expr _ (HsDo {}) = panic "dsExpr:HsDo"
ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld"
+ds_expr _ (XExpr {}) = panic "dsExpr: XExpr"
+
------------------------------
dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
@@ -938,9 +942,9 @@ dsDo stmts
; rhss' <- sequence rhss
- ; let body' = noLoc $ HsDo DoExpr (noLoc stmts) body_ty
+ ; let body' = noLoc $ HsDo body_ty DoExpr (noLoc stmts)
- ; let fun = L noSrcSpan $ HsLam $
+ ; let fun = L noSrcSpan $ HsLam noExt $
MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats
body']
, mg_arg_tys = arg_tys
@@ -972,15 +976,15 @@ dsDo stmts
later_pats = rec_tup_pats
rets = map noLoc rec_rets
mfix_app = nlHsSyntaxApps mfix_op [mfix_arg]
- mfix_arg = noLoc $ HsLam
+ mfix_arg = noLoc $ HsLam noExt
(MG { mg_alts = noLoc [mkSimpleMatch
LambdaExpr
[mfix_pat] body]
, mg_arg_tys = [tup_ty], mg_res_ty = body_ty
, mg_origin = Generated })
- mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTupId rec_tup_pats
- body = noLoc $ HsDo
- DoExpr (noLoc (rec_stmts ++ [ret_stmt])) body_ty
+ mfix_pat = noLoc $ LazyPat noExt $ mkBigLHsPatTupId rec_tup_pats
+ body = noLoc $ HsDo body_ty
+ DoExpr (noLoc (rec_stmts ++ [ret_stmt]))
ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets]
ret_stmt = noLoc $ mkLastStmt ret_app
-- This LastStmt will be desugared with dsDo,
@@ -1142,9 +1146,9 @@ we're not directly in an HsWrap, reject.
checkForcedEtaExpansion :: HsExpr GhcTc -> Type -> DsM ()
checkForcedEtaExpansion expr ty
| Just var <- case expr of
- HsVar (L _ var) -> Just var
- HsConLikeOut (RealDataCon dc) -> Just (dataConWrapId dc)
- _ -> Nothing
+ HsVar _ (L _ var) -> Just var
+ HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc)
+ _ -> Nothing
, let bad_tys = badUseOfLevPolyPrimop var ty
, not (null bad_tys)
= levPolyPrimopErr var ty bad_tys
diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs
index e4127ad97f..b0470ef487 100644
--- a/compiler/deSugar/DsGRHSs.hs
+++ b/compiler/deSugar/DsGRHSs.hs
@@ -135,24 +135,25 @@ isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
-- * Trivial wappings of these
-- The arguments to Just are any HsTicks that we have found,
-- because we still want to tick then, even it they are always evaluated.
-isTrueLHsExpr (L _ (HsVar (L _ v))) | v `hasKey` otherwiseIdKey
- || v `hasKey` getUnique trueDataConId
- = Just return
+isTrueLHsExpr (L _ (HsVar _ (L _ v))) | v `hasKey` otherwiseIdKey
+ || v `hasKey` getUnique trueDataConId
+ = Just return
-- trueDataConId doesn't have the same unique as trueDataCon
-isTrueLHsExpr (L _ (HsConLikeOut con)) | con `hasKey` getUnique trueDataCon = Just return
-isTrueLHsExpr (L _ (HsTick tickish e))
+isTrueLHsExpr (L _ (HsConLikeOut _ con))
+ | con `hasKey` getUnique trueDataCon = Just return
+isTrueLHsExpr (L _ (HsTick _ tickish e))
| Just ticks <- isTrueLHsExpr e
= Just (\x -> do wrapped <- ticks x
return (Tick tickish wrapped))
-- This encodes that the result is constant True for Hpc tick purposes;
-- which is specifically what isTrueLHsExpr is trying to find out.
-isTrueLHsExpr (L _ (HsBinTick ixT _ e))
+isTrueLHsExpr (L _ (HsBinTick _ ixT _ e))
| Just ticks <- isTrueLHsExpr e
= Just (\x -> do e <- ticks x
this_mod <- getModule
return (Tick (HpcTick this_mod ixT) e))
-isTrueLHsExpr (L _ (HsPar e)) = isTrueLHsExpr e
+isTrueLHsExpr (L _ (HsPar _ e)) = isTrueLHsExpr e
isTrueLHsExpr _ = Nothing
{-
diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs
index 7ca85eb3f5..36c2730aff 100644
--- a/compiler/deSugar/DsListComp.hs
+++ b/compiler/deSugar/DsListComp.hs
@@ -82,7 +82,7 @@ dsListComp lquals res_ty = do
-- of that comprehension that we need in the outer comprehension into such an expression
-- and the type of the elements that it outputs (tuples of binders)
dsInnerListComp :: (ParStmtBlock GhcTc GhcTc) -> DsM (CoreExpr, Type)
-dsInnerListComp (ParStmtBlock stmts bndrs _)
+dsInnerListComp (ParStmtBlock _ stmts bndrs _)
= do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs
list_ty = mkListTy bndrs_tuple_type
@@ -90,6 +90,7 @@ dsInnerListComp (ParStmtBlock stmts bndrs _)
; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty
; return (expr, bndrs_tuple_type) }
+dsInnerListComp (XParStmtBlock{}) = panic "dsInnerListComp"
-- This function factors out commonality between the desugaring strategies for GroupStmt.
-- Given such a statement it gives you back an expression representing how to compute the transformed
@@ -105,7 +106,8 @@ dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderM
to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys
-- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
- (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock stmts from_bndrs noSyntaxExpr)
+ (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock noExt stmts
+ from_bndrs noSyntaxExpr)
-- Work out what arguments should be supplied to that expression: i.e. is an extraction
-- function required? If so, create that desugared function and add to arguments
@@ -253,7 +255,7 @@ deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list
; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
quals list }
where
- bndrs_s = [bs | ParStmtBlock _ bs _ <- stmtss_w_bndrs]
+ bndrs_s = [bs | ParStmtBlock _ _ bs _ <- stmtss_w_bndrs]
-- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
pat = mkBigLHsPatTupId pats
@@ -623,13 +625,15 @@ dePArrParComp qss quals = do
deParStmt [] =
-- empty parallel statement lists have no source representation
panic "DsListComp.dePArrComp: Empty parallel list comprehension"
- deParStmt (ParStmtBlock qs xs _:qss) = do -- first statement
+ deParStmt (ParStmtBlock _ qs xs _:qss) = do -- first statement
let res_expr = mkLHsVarTuple xs
cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])
parStmts qss (mkLHsVarPatTup xs) cqs
+ deParStmt (XParStmtBlock{}:_) = panic "dePArrParComp"
---
parStmts [] pa cea = return (pa, cea)
- parStmts (ParStmtBlock qs xs _:qss) pa cea = do -- subsequent statements (zip'ed)
+ parStmts (ParStmtBlock _ qs xs _:qss) pa cea = do
+ -- subsequent statements (zip'ed)
zipP <- dsDPHBuiltin zipPVar
let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs]
ty'cea = parrElemType cea
@@ -638,6 +642,7 @@ dePArrParComp qss quals = do
let ty'cqs = parrElemType cqs
cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
parStmts qss pa' cea'
+ parStmts (XParStmtBlock{}:_) _ _ = panic "dePArrParComp"
-- generate Core corresponding to `\p -> e'
--
@@ -777,7 +782,7 @@ dsMcStmt (ParStmt blocks mzip_op bind_op bind_ty) stmts_rest
; mzip_op' <- dsExpr mzip_op
; let -- The pattern variables
- pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ bs _ <- blocks]
+ pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ _ bs _ <- blocks]
-- Pattern with tuples of variables
-- [v1,v2,v3] => (v1, (v2, v3))
pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats
@@ -788,9 +793,10 @@ dsMcStmt (ParStmt blocks mzip_op bind_op bind_ty) stmts_rest
; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest }
where
- ds_inner (ParStmtBlock stmts bndrs return_op)
+ ds_inner (ParStmtBlock _ stmts bndrs return_op)
= do { exp <- dsInnerMonadComp stmts bndrs return_op
; return (exp, mkBigCoreVarTupTy bndrs) }
+ ds_inner (XParStmtBlock{}) = panic "dsMcStmt"
dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index c8f70e03e7..fd8da266ae 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -77,13 +77,14 @@ dsBracket brack splices
where
new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendingTcSplice n e <- splices]
- do_brack (VarBr _ n) = do { MkC e1 <- lookupOcc n ; return e1 }
- do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 }
- do_brack (PatBr p) = do { MkC p1 <- repTopP p ; return p1 }
- do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 }
- do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
- do_brack (DecBrL _) = panic "dsBracket: unexpected DecBrL"
- do_brack (TExpBr e) = do { MkC e1 <- repLE e ; return e1 }
+ do_brack (VarBr _ _ n) = do { MkC e1 <- lookupOcc n ; return e1 }
+ do_brack (ExpBr _ e) = do { MkC e1 <- repLE e ; return e1 }
+ do_brack (PatBr _ p) = do { MkC p1 <- repTopP p ; return p1 }
+ do_brack (TypBr _ t) = do { MkC t1 <- repLTy t ; return t1 }
+ do_brack (DecBrG _ gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
+ do_brack (DecBrL {}) = panic "dsBracket: unexpected DecBrL"
+ do_brack (TExpBr _ e) = do { MkC e1 <- repLE e ; return e1 }
+ do_brack (XBracket {}) = panic "dsBracket: unexpected XBracket"
{- -------------- Examples --------------------
@@ -187,8 +188,8 @@ hsSigTvBinders binds
= concatMap get_scoped_tvs sigs
where
sigs = case binds of
- ValBindsIn _ sigs -> sigs
- ValBindsOut _ sigs -> sigs
+ ValBinds _ _ sigs -> sigs
+ XValBindsLR (NValBinds _ sigs) -> sigs
get_scoped_tvs :: LSig GhcRn -> [Name]
get_scoped_tvs (L _ signature)
@@ -724,7 +725,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)
-------------------------------------------------------
@@ -980,18 +981,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
--
@@ -1040,7 +1043,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
| n `hasKey` funTyConKey = repArrowTyCon
@@ -1054,47 +1057,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
@@ -1102,9 +1105,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)
@@ -1138,10 +1141,11 @@ repRole (L _ Nothing) = rep2 inferRName []
repSplice :: HsSplice GhcRn -> DsM (Core a)
-- See Note [How brackets and nested splices are handled] in TcSplice
-- We return a CoreExpr of any old type; the context should know
-repSplice (HsTypedSplice _ n _) = rep_splice n
-repSplice (HsUntypedSplice _ n _) = rep_splice n
-repSplice (HsQuasiQuote n _ _ _) = rep_splice n
-repSplice e@(HsSpliced _ _) = pprPanic "repSplice" (ppr e)
+repSplice (HsTypedSplice _ _ n _) = rep_splice n
+repSplice (HsUntypedSplice _ _ n _) = rep_splice n
+repSplice (HsQuasiQuote _ n _ _ _) = rep_splice n
+repSplice e@(HsSpliced {}) = pprPanic "repSplice" (ppr e)
+repSplice e@(XSplice {}) = pprPanic "repSplice" (ppr e)
rep_splice :: Name -> DsM (Core a)
rep_splice splice_name
@@ -1166,7 +1170,7 @@ repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ)
repLE (L loc e) = putSrcSpanDs loc (repE e)
repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ)
-repE (HsVar (L _ x)) =
+repE (HsVar _ (L _ x)) =
do { mb_val <- dsLookupMetaEnv x
; case mb_val of
Nothing -> do { str <- globalVar x
@@ -1174,45 +1178,46 @@ repE (HsVar (L _ x)) =
Just (DsBound y) -> repVarOrCon x (coreVar y)
Just (DsSplice e) -> do { e' <- dsExpr e
; return (MkC e') } }
-repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
-repE (HsOverLabel _ s) = repOverLabel s
+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))
+repE e@(HsRecFld _ f) = case f of
+ Unambiguous x _ -> repE (HsVar noExt (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
-repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
-repE (HsLit l) = do { a <- repLiteral l; repLit a }
-repE (HsLam (MG { mg_alts = L _ [m] })) = repLambda m
-repE (HsLamCase (MG { mg_alts = L _ ms }))
+repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a }
+repE (HsLit _ l) = do { a <- repLiteral l; repLit a }
+repE (HsLam _ (MG { mg_alts = L _ [m] })) = repLambda m
+repE (HsLamCase _ (MG { mg_alts = L _ ms }))
= do { ms' <- mapM repMatchTup ms
; core_ms <- coreList matchQTyConName ms'
; repLamCase core_ms }
-repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
-repE (HsAppType e t) = do { a <- repLE e
+repE (HsApp _ x y) = do {a <- repLE x; b <- repLE y; repApp a b}
+repE (HsAppType t e) = do { a <- repLE e
; s <- repLTy (hswc_body t)
; repAppType a s }
-repE (OpApp e1 op _ e2) =
+repE (OpApp _ e1 op e2) =
do { arg1 <- repLE e1;
arg2 <- repLE e2;
the_op <- repLE op ;
repInfixApp arg1 the_op arg2 }
-repE (NegApp x _) = do
+repE (NegApp _ x _) = do
a <- repLE x
negateVar <- lookupOcc negateName >>= repVar
negateVar `repApp` a
-repE (HsPar x) = repLE x
-repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
-repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
-repE (HsCase e (MG { mg_alts = L _ ms }))
+repE (HsPar _ x) = repLE x
+repE (SectionL _ x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
+repE (SectionR _ x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
+repE (HsCase _ e (MG { mg_alts = L _ ms }))
= do { arg <- repLE e
; ms2 <- mapM repMatchTup ms
; core_ms2 <- coreList matchQTyConName ms2
; repCaseE arg core_ms2 }
-repE (HsIf _ x y z) = do
+repE (HsIf _ _ x y z) = do
a <- repLE x
b <- repLE y
c <- repLE z
@@ -1221,13 +1226,13 @@ repE (HsMultiIf _ alts)
= do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
; expr' <- repMultiIf (nonEmptyCoreList alts')
; wrapGenSyms (concat binds) expr' }
-repE (HsLet (L _ bs) e) = do { (ss,ds) <- repBinds bs
+repE (HsLet _ (L _ bs) e) = do { (ss,ds) <- repBinds bs
; e2 <- addBinds ss (repLE e)
; z <- repLetE ds e2
; wrapGenSyms ss z }
-- FIXME: I haven't got the types here right yet
-repE e@(HsDo ctxt (L _ sts) _)
+repE e@(HsDo _ ctxt (L _ sts))
| case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
= do { (ss,zs) <- repLSts sts;
e' <- repDoE (nonEmptyCoreList zs);
@@ -1243,13 +1248,13 @@ repE e@(HsDo ctxt (L _ sts) _)
repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
-repE e@(ExplicitTuple es boxed)
+repE e@(ExplicitTuple _ es boxed)
| not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
- | isBoxed boxed = do { xs <- repLEs [e | L _ (Present e) <- es]; repTup xs }
- | otherwise = do { xs <- repLEs [e | L _ (Present e) <- es]
- ; repUnboxedTup xs }
+ | isBoxed boxed = do { xs <- repLEs [e | L _ (Present _ e) <- es]; repTup xs }
+ | otherwise = do { xs <- repLEs [e | L _ (Present _ e) <- es]
+ ; repUnboxedTup xs }
-repE (ExplicitSum alt arity e _)
+repE (ExplicitSum _ alt arity e)
= do { e1 <- repLE e
; repUnboxedSum e1 alt arity }
@@ -1262,7 +1267,7 @@ repE (RecordUpd { rupd_expr = e, rupd_flds = flds })
fs <- repUpdFields flds;
repRecUpd x fs }
-repE (ExprWithTySig e ty)
+repE (ExprWithTySig ty e)
= do { e1 <- repLE e
; t1 <- repHsSigWcType ty
; repSigExp e1 t1 }
@@ -1284,9 +1289,9 @@ repE (ArithSeq _ _ aseq) =
ds3 <- repLE e3
repFromThenTo ds1 ds2 ds3
-repE (HsSpliceE splice) = repSplice splice
+repE (HsSpliceE _ splice) = repSplice splice
repE (HsStatic _ e) = repLE e >>= rep2 staticEName . (:[]) . unC
-repE (HsUnboundVar uv) = do
+repE (HsUnboundVar _ uv) = do
occ <- occNameLit (unboundVarOcc uv)
sname <- repNameS occ
repUnboundVar sname
@@ -1295,7 +1300,6 @@ repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
-repE e@(HsTcBracketOut {}) = notHandled "TH brackets" (ppr e)
repE e = notHandled "Expression form" (ppr e)
-----------------------------------------------------------------------------
@@ -1359,7 +1363,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)
@@ -1423,10 +1427,11 @@ repSts (ParStmt stmt_blocks _ _ _ : ss) =
where
rep_stmt_block :: ParStmtBlock GhcRn GhcRn
-> DsM ([GenSymBind], Core [TH.StmtQ])
- rep_stmt_block (ParStmtBlock stmts _ _) =
+ rep_stmt_block (ParStmtBlock _ stmts _ _) =
do { (ss1, zs) <- repSts (map unLoc stmts)
; zs1 <- coreList stmtQTyConName zs
; return (ss1, zs1) }
+ rep_stmt_block (XParStmtBlock{}) = panic "repSts"
repSts [LastStmt e _ _]
= do { e2 <- repLE e
; z <- repNoBindSt e2
@@ -1461,12 +1466,12 @@ repBinds (HsValBinds decs)
rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
-- Assumes: all the binders of the binding are already in the meta-env
-rep_val_binds (ValBindsOut binds sigs)
+rep_val_binds (XValBindsLR (NValBinds binds sigs))
= do { core1 <- rep_binds (unionManyBags (map snd binds))
; core2 <- rep_sigs sigs
; return (core1 ++ core2) }
-rep_val_binds (ValBindsIn _ _)
- = panic "rep_val_binds: ValBindsIn"
+rep_val_binds (ValBinds _ _ _)
+ = panic "rep_val_binds: ValBinds"
rep_binds :: LHsBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
rep_binds = mapM rep_bind . bagToList
@@ -1648,19 +1653,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 _ ps _ Nothing) = do { qs <- repLPs ps; repPlist qs }
+repP (ListPat x ps ty1 (Just (_,e))) = do { p <- repP (ListPat x ps ty1 Nothing)
+ ; 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
@@ -1677,13 +1686,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)
@@ -2234,7 +2243,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] }
@@ -2394,7 +2403,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
@@ -2407,6 +2416,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)
diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs
index f4d669c156..7bec30acdc 100644
--- a/compiler/deSugar/DsUtils.hs
+++ b/compiler/deSugar/DsUtils.hs
@@ -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)
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index 5f9f8dca8b..c4fb7e7f30 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -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)
@@ -975,18 +977,18 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool
-- real comparison is on HsExpr's
-- strip parens
- exp (HsPar (L _ e)) e' = exp e e'
- exp e (HsPar (L _ e')) = exp e e'
+ exp (HsPar _ (L _ e)) e' = exp e e'
+ exp e (HsPar _ (L _ e')) = exp e e'
-- because the expressions do not necessarily have the same type,
-- we have to compare the wrappers
- exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e'
- exp (HsVar i) (HsVar i') = i == i'
- exp (HsConLikeOut c) (HsConLikeOut c') = c == c'
+ exp (HsWrap _ h e) (HsWrap _ h' e') = wrap h h' && exp e e'
+ exp (HsVar _ i) (HsVar _ i') = i == i'
+ exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c'
-- the instance for IPName derives using the id, so this works if the
-- above does
- exp (HsIPVar i) (HsIPVar i') = i == i'
- exp (HsOverLabel l x) (HsOverLabel l' x') = l == l' && x == x'
- exp (HsOverLit l) (HsOverLit l') =
+ exp (HsIPVar _ i) (HsIPVar _ i') = i == i'
+ exp (HsOverLabel _ l x) (HsOverLabel _ l' x') = l == l' && x == x'
+ exp (HsOverLit _ l) (HsOverLit _ l') =
-- Overloaded lits are equal if they have the same type
-- and the data is the same.
-- this is coarser than comparing the SyntaxExpr's in l and l',
@@ -994,20 +996,20 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
-- because these expressions get written as a bunch of different variables
-- (presumably to improve sharing)
eqType (overLitType l) (overLitType l') && l == l'
- exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2'
+ exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2'
-- the fixities have been straightened out by now, so it's safe
-- to ignore them?
- exp (OpApp l o _ ri) (OpApp l' o' _ ri') =
+ exp (OpApp _ l o ri) (OpApp _ l' o' ri') =
lexp l l' && lexp o o' && lexp ri ri'
- exp (NegApp e n) (NegApp e' n') = lexp e e' && syn_exp n n'
- exp (SectionL e1 e2) (SectionL e1' e2') =
+ exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n'
+ exp (SectionL _ e1 e2) (SectionL _ e1' e2') =
lexp e1 e1' && lexp e2 e2'
- exp (SectionR e1 e2) (SectionR e1' e2') =
+ exp (SectionR _ e1 e2) (SectionR _ e1' e2') =
lexp e1 e1' && lexp e2 e2'
- exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) =
+ exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) =
eq_list tup_arg es1 es2
- exp (ExplicitSum _ _ e _) (ExplicitSum _ _ e' _) = lexp e e'
- exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') =
+ exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e'
+ exp (HsIf _ _ e e1 e2) (HsIf _ _ e' e1' e2') =
lexp e e' && lexp e1 e1' && lexp e2 e2'
-- Enhancement: could implement equality for more expressions
@@ -1029,8 +1031,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
wrap res_wrap1 res_wrap2
---------
- tup_arg (L _ (Present e1)) (L _ (Present e2)) = lexp e1 e2
- tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2
+ tup_arg (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2
+ tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2
tup_arg _ _ = False
---------
@@ -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)
{-
diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs
index 355927deef..c7bff64ff3 100644
--- a/compiler/deSugar/MatchLit.hs
+++ b/compiler/deSugar/MatchLit.hs
@@ -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]
~~~~~~~~~~~~~~~~~~~~~~~~
@@ -239,14 +241,14 @@ warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr
getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name)
-- See if the expression is an Integral literal
-- Remember to look through automatically-added tick-boxes! (Trac #8384)
-getLHsIntegralLit (L _ (HsPar e)) = getLHsIntegralLit e
-getLHsIntegralLit (L _ (HsTick _ e)) = getLHsIntegralLit e
-getLHsIntegralLit (L _ (HsBinTick _ _ e)) = getLHsIntegralLit e
-getLHsIntegralLit (L _ (HsOverLit over_lit)) = getIntegralLit over_lit
+getLHsIntegralLit (L _ (HsPar _ e)) = getLHsIntegralLit e
+getLHsIntegralLit (L _ (HsTick _ _ e)) = getLHsIntegralLit e
+getLHsIntegralLit (L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e
+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)
diff --git a/compiler/deSugar/PmExpr.hs b/compiler/deSugar/PmExpr.hs
index aa1bc814c5..f008a31d4b 100644
--- a/compiler/deSugar/PmExpr.hs
+++ b/compiler/deSugar/PmExpr.hs
@@ -236,32 +236,32 @@ lhsExprToPmExpr (L _ e) = hsExprToPmExpr e
hsExprToPmExpr :: HsExpr GhcTc -> PmExpr
-hsExprToPmExpr (HsVar x) = PmExprVar (idName (unLoc x))
-hsExprToPmExpr (HsConLikeOut c) = PmExprVar (conLikeName c)
-hsExprToPmExpr (HsOverLit olit) = PmExprLit (PmOLit False olit)
-hsExprToPmExpr (HsLit lit) = PmExprLit (PmSLit lit)
+hsExprToPmExpr (HsVar _ x) = PmExprVar (idName (unLoc x))
+hsExprToPmExpr (HsConLikeOut _ c) = PmExprVar (conLikeName c)
+hsExprToPmExpr (HsOverLit _ olit) = PmExprLit (PmOLit False olit)
+hsExprToPmExpr (HsLit _ lit) = PmExprLit (PmSLit lit)
-hsExprToPmExpr e@(NegApp _ neg_e)
+hsExprToPmExpr e@(NegApp _ _ neg_e)
| PmExprLit (PmOLit False ol) <- synExprToPmExpr neg_e
= PmExprLit (PmOLit True ol)
| otherwise = PmExprOther e
-hsExprToPmExpr (HsPar (L _ e)) = hsExprToPmExpr e
+hsExprToPmExpr (HsPar _ (L _ e)) = hsExprToPmExpr e
-hsExprToPmExpr e@(ExplicitTuple ps boxity)
+hsExprToPmExpr e@(ExplicitTuple _ ps boxity)
| all tupArgPresent ps = mkPmExprData tuple_con tuple_args
| otherwise = PmExprOther e
where
tuple_con = tupleDataCon boxity (length ps)
- tuple_args = [ lhsExprToPmExpr e | L _ (Present e) <- ps ]
+ tuple_args = [ lhsExprToPmExpr e | L _ (Present _ e) <- ps ]
-hsExprToPmExpr e@(ExplicitList _elem_ty mb_ol elems)
+hsExprToPmExpr e@(ExplicitList _ mb_ol elems)
| Nothing <- mb_ol = foldr cons nil (map lhsExprToPmExpr elems)
| otherwise = PmExprOther e {- overloaded list: No PmExprApp -}
where
cons x xs = mkPmExprData consDataCon [x,xs]
nil = mkPmExprData nilDataCon []
-hsExprToPmExpr (ExplicitPArr _elem_ty elems)
+hsExprToPmExpr (ExplicitPArr _ elems)
= mkPmExprData (parrFakeCon (length elems)) (map lhsExprToPmExpr elems)
@@ -272,16 +272,15 @@ hsExprToPmExpr (ExplicitPArr _elem_ty elems)
-- con <- dsLookupDataCon (unLoc c)
-- args <- mapM lhsExprToPmExpr (hsRecFieldsArgs binds)
-- return (PmExprCon con args)
-hsExprToPmExpr e@(RecordCon _ _ _ _) = PmExprOther e
-
-hsExprToPmExpr (HsTick _ e) = lhsExprToPmExpr e
-hsExprToPmExpr (HsBinTick _ _ e) = lhsExprToPmExpr e
-hsExprToPmExpr (HsTickPragma _ _ _ e) = lhsExprToPmExpr e
-hsExprToPmExpr (HsSCC _ _ e) = lhsExprToPmExpr e
-hsExprToPmExpr (HsCoreAnn _ _ e) = lhsExprToPmExpr e
-hsExprToPmExpr (ExprWithTySig e _) = lhsExprToPmExpr e
-hsExprToPmExpr (ExprWithTySigOut e _) = lhsExprToPmExpr e
-hsExprToPmExpr (HsWrap _ e) = hsExprToPmExpr e
+hsExprToPmExpr e@(RecordCon {}) = PmExprOther e
+
+hsExprToPmExpr (HsTick _ _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (HsBinTick _ _ _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (HsTickPragma _ _ _ _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (HsSCC _ _ _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (HsCoreAnn _ _ _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (ExprWithTySig _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (HsWrap _ _ e) = hsExprToPmExpr e
hsExprToPmExpr e = PmExprOther e -- the rest are not handled by the oracle
synExprToPmExpr :: SyntaxExpr GhcTc -> PmExpr
View Lorry Controller Status