summaryrefslogtreecommitdiff
path: root/compiler/deSugar
diff options
context:
space:
mode:
authorBen Gamari <ben@smart-cactus.org>2017-11-21 14:28:58 -0500
committerBen Gamari <ben@smart-cactus.org>2017-11-21 16:36:43 -0500
commit314bc31489f1f4cd69e913c3b1e33236b2bdf553 (patch)
treeb960f9b02ec06f9d61df019f53655b4e53847bd7 /compiler/deSugar
parent0b20d9c51d627febab34b826fccf522ca8bac323 (diff)
downloadhaskell-314bc31489f1f4cd69e913c3b1e33236b2bdf553.tar.gz
Revert "trees that grow" work
As documented in #14490, the Data instances currently blow up compilation time by too much to stomach. Alan will continue working on this in a branch and we will perhaps merge to 8.2 before 8.2.1 to avoid having to perform painful cherry-picks in 8.2 minor releases. Reverts haddock submodule. This reverts commit 47ad6578ea460999b53eb4293c3a3b3017a56d65. This reverts commit e3ec2e7ae94524ebd111963faf34b84d942265b4. This reverts commit 438dd1cbba13d35f3452b4dcef3f94ce9a216905. This reverts commit 0ff152c9e633accca48815e26e59d1af1fe44ceb.
Diffstat (limited to 'compiler/deSugar')
-rw-r--r--compiler/deSugar/Check.hs61
-rw-r--r--compiler/deSugar/Coverage.hs218
-rw-r--r--compiler/deSugar/DsArrows.hs80
-rw-r--r--compiler/deSugar/DsExpr.hs122
-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, 456 insertions, 498 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index ae1de7716d..d49a5c3ab8 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -675,12 +675,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 noExt) }
+ , pm_grd_expr = PmExprOther EWildPat }
{-# 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
@@ -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])
- SigPat _ty p -> translatePat fam_insts (unLoc p)
+ SigPatOut p _ty -> 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,26 +751,26 @@ translatePat fam_insts pat = case pat of
return [xp,g]
-- (n + k) ===> x (True <- x >= k) (n <- x-k)
- NPlusKPat ty (L _ _n) _k1 _k2 _ge _minus -> mkCanFailPmPat ty
+ NPlusKPat (L _ _n) _k1 _k2 _ge _minus ty -> mkCanFailPmPat ty
-- (fun -> pat) ===> x (pat <- fun x)
- ViewPat arg_ty lexpr lpat -> do
+ ViewPat lexpr lpat arg_ty -> 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 noExt lexpr xe)
+ let g = mkGuard ps (HsApp 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 x lpats elem_ty (Just (pat_ty, _to_list))
+ ListPat 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 x lpats e_ty Nothing)
+ translatePat fam_insts (ListPat lpats e_ty Nothing)
-- See Note [Guards and Approximation]
| otherwise -> mkCanFailPmPat pat_ty
@@ -799,27 +799,26 @@ translatePat fam_insts pat = case pat of
, pm_con_dicts = dicts
, pm_con_args = args }]
- NPat ty (L _ ol) mb_neg _eq -> translateNPat fam_insts ol mb_neg ty
+ NPat (L _ ol) mb_neg _eq ty -> 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 noExt . HsChar src) (unpackFS s))
+ translatePatVec fam_insts (map (LitPat . HsChar src) (unpackFS s))
| otherwise -> return [mkLitPattern lit]
- PArrPat ty ps -> do
+ PArrPat ps ty -> 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 tys ps boxity -> do
+ TuplePat ps boxity tys -> 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 ty p alt arity -> do
+ SumPat p alt arity ty -> do
tidy_p <- translatePat fam_insts (unLoc p)
let sum_con = RealDataCon (sumDataCon alt arity)
return [vanillaConPattern sum_con ty tidy_p]
@@ -828,23 +827,23 @@ translatePat fam_insts pat = case pat of
-- Not supposed to happen
ConPatIn {} -> panic "Check.translatePat: ConPatIn"
SplicePat {} -> panic "Check.translatePat: SplicePat"
- XPat {} -> panic "Check.translatePat: XPat"
+ SigPatIn {} -> panic "Check.translatePat: SigPatIn"
-- | Translate an overloaded literal (see `tidyNPat' in deSugar/MatchLit.hs)
translateNPat :: FamInstEnvs
-> HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> Type
-> DsM PatVec
-translateNPat fam_insts (OverLit (OverLitTc False ty) val _ ) mb_neg outer_ty
+translateNPat fam_insts (OverLit val False _ ty) mb_neg outer_ty
| not type_change, isStringTy ty, HsIsString src s <- val, Nothing <- mb_neg
- = translatePat fam_insts (LitPat noExt (HsString src s))
+ = translatePat fam_insts (LitPat (HsString src s))
| not type_change, isIntTy ty, HsIntegral i <- val
= translatePat fam_insts
- (LitPat noExt $ case mb_neg of
- Nothing -> HsInt noExt i
- Just _ -> HsInt noExt (negateIntegralLit i))
+ (LitPat $ case mb_neg of
+ Nothing -> HsInt def i
+ Just _ -> HsInt def (negateIntegralLit i))
| not type_change, isWordTy ty, HsIntegral i <- val
= translatePat fam_insts
- (LitPat noExt $ case mb_neg of
+ (LitPat $ 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))
@@ -1217,7 +1216,7 @@ mkPmId ty = getUniqueM >>= \unique ->
mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr GhcTc)
mkPmId2Forms ty = do
x <- mkPmId ty
- return (PmVar x, noLoc (HsVar noExt (noLoc x)))
+ return (PmVar x, noLoc (HsVar (noLoc x)))
-- ----------------------------------------------------------------------------
-- * Converting between Value Abstractions, Patterns and PmExpr
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index 5bdff0fe67..862e564aed 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -459,15 +459,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 (HsAppType {}) = True
-isGoodBreakExpr (OpApp {}) = True
-isGoodBreakExpr _other = False
+isGoodBreakExpr (HsApp {}) = True
+isGoodBreakExpr (HsAppTypeOut {}) = True
+isGoodBreakExpr (OpApp {}) = True
+isGoodBreakExpr _other = False
isCallSite :: HsExpr GhcTc -> Bool
-isCallSite HsApp{} = True
-isCallSite HsAppType{} = True
-isCallSite OpApp{} = True
+isCallSite HsApp{} = True
+isCallSite HsAppTypeOut{} = True
+isCallSite OpApp{} = True
isCallSite _ = False
addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
@@ -489,58 +489,55 @@ 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 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) =
+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) =
liftM4 OpApp
- (return fix)
(addTickLHsExpr e1)
(addTickLHsExprNever e2)
+ (return fix)
(addTickLHsExpr e3)
-addTickHsExpr (NegApp x e neg) =
- liftM2 (NegApp x)
+addTickHsExpr (NegApp e neg) =
+ liftM2 NegApp
(addTickLHsExpr e)
(addTickSyntaxExpr hpcSrcSpan neg)
-addTickHsExpr (HsPar x e) =
- liftM (HsPar x) (addTickLHsExprEvalInner e)
-addTickHsExpr (SectionL x e1 e2) =
- liftM2 (SectionL x)
+addTickHsExpr (HsPar e) =
+ liftM HsPar (addTickLHsExprEvalInner e)
+addTickHsExpr (SectionL e1 e2) =
+ liftM2 SectionL
(addTickLHsExpr e1)
(addTickLHsExprNever e2)
-addTickHsExpr (SectionR x e1 e2) =
- liftM2 (SectionR x)
+addTickHsExpr (SectionR e1 e2) =
+ liftM2 SectionR
(addTickLHsExprNever e1)
(addTickLHsExpr e2)
-addTickHsExpr (ExplicitTuple x es boxity) =
- liftM2 (ExplicitTuple x)
+addTickHsExpr (ExplicitTuple es boxity) =
+ liftM2 ExplicitTuple
(mapM addTickTupArg es)
(return boxity)
-addTickHsExpr (ExplicitSum ty tag arity e) = do
+addTickHsExpr (ExplicitSum tag arity e ty) = do
e' <- addTickLHsExpr e
- return (ExplicitSum ty tag arity e')
-addTickHsExpr (HsCase x e mgs) =
- liftM2 (HsCase x)
+ return (ExplicitSum tag arity e' ty)
+addTickHsExpr (HsCase e mgs) =
+ liftM2 HsCase
(addTickLHsExpr e) -- not an EvalInner; e might not necessarily
-- be evaluated.
(addTickMatchGroup False mgs)
-addTickHsExpr (HsIf x cnd e1 e2 e3) =
- liftM3 (HsIf x cnd)
+addTickHsExpr (HsIf cnd e1 e2 e3) =
+ liftM3 (HsIf cnd)
(addBinTickLHsExpr (BinBox CondBinBox) e1)
(addTickLHsExprOptAlt True e2)
(addTickLHsExprOptAlt True e3)
@@ -548,14 +545,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 x (L l binds) e) =
+addTickHsExpr (HsLet (L l binds) e) =
bindLocals (collectLocalBinders binds) $
- liftM2 (HsLet x . L l)
+ liftM2 (HsLet . L l)
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsExprLetBody e)
-addTickHsExpr (HsDo srcloc cxt (L l stmts))
+addTickHsExpr (HsDo cxt (L l stmts) srcloc)
= do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
- ; return (HsDo srcloc cxt (L l stmts')) }
+ ; return (HsDo cxt (L l stmts') srcloc) }
where
forQual = case cxt of
ListComp -> Just $ BinBox QualBinBox
@@ -585,12 +582,12 @@ addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })
; flds' <- mapM addTickHsRecField flds
; return (expr { rupd_expr = e', rupd_flds = flds' }) }
-addTickHsExpr (ExprWithTySig ty e) =
+addTickHsExpr (ExprWithTySig e ty) =
liftM2 ExprWithTySig
- (return ty)
(addTickLHsExprNever e) -- No need to tick the inner expression
- -- for expressions with signatures
-addTickHsExpr (ArithSeq ty wit arith_seq) =
+ -- for expressions with signatures
+ (return ty)
+addTickHsExpr (ArithSeq ty wit arith_seq) =
liftM3 ArithSeq
(return ty)
(addTickWit wit)
@@ -600,26 +597,26 @@ addTickHsExpr (ArithSeq ty wit arith_seq) =
return (Just fl')
-- We might encounter existing ticks (multiple Coverage passes)
-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 (HsTick t e) =
+ liftM (HsTick t) (addTickLHsExprNever e)
+addTickHsExpr (HsBinTick t0 t1 e) =
+ liftM (HsBinTick 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 x src nm e) =
- liftM3 (HsSCC x)
+addTickHsExpr (HsSCC src nm e) =
+ liftM3 HsSCC
(return src)
(return nm)
(addTickLHsExpr e)
-addTickHsExpr (HsCoreAnn x src nm e) =
- liftM3 (HsCoreAnn x)
+addTickHsExpr (HsCoreAnn src nm e) =
+ liftM3 HsCoreAnn
(return src)
(return nm)
(addTickLHsExpr e)
@@ -627,23 +624,27 @@ addTickHsExpr e@(HsBracket {}) = return e
addTickHsExpr e@(HsTcBracketOut {}) = return e
addTickHsExpr e@(HsRnBracketOut {}) = return e
addTickHsExpr e@(HsSpliceE {}) = return e
-addTickHsExpr (HsProc x pat cmdtop) =
- liftM2 (HsProc x)
+addTickHsExpr (HsProc pat cmdtop) =
+ liftM2 HsProc
(addTickLPat pat)
(liftL (addTickHsCmdTop) cmdtop)
-addTickHsExpr (HsWrap x w e) =
- liftM2 (HsWrap x)
+addTickHsExpr (HsWrap w e) =
+ liftM2 HsWrap
(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 x e)) = do { e' <- addTickLHsExpr e
- ; return (L l (Present x e')) }
+addTickTupArg (L l (Present e)) = do { e' <- addTickLHsExpr e
+ ; return (L l (Present 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))
@@ -761,8 +762,8 @@ addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
| otherwise = addTickLHsExprRHS e
addTickApplicativeArg
- :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
- -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
+ :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc)
+ -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc)
addTickApplicativeArg isGuard (op, arg) =
liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
where
@@ -779,12 +780,11 @@ addTickApplicativeArg isGuard (op, arg) =
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
-> TM (ParStmtBlock GhcTc GhcTc)
-addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) =
- liftM3 (ParStmtBlock x)
+addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) =
+ liftM3 ParStmtBlock
(addTickLStmts isGuard stmts)
(return ids)
(addTickSyntaxExpr hpcSrcSpan returnExpr)
-addTickStmtAndBinders _ (XParStmtBlock{}) = panic "addTickStmtAndBinders"
addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
addTickHsLocalBinds (HsValBinds binds) =
@@ -795,17 +795,15 @@ addTickHsLocalBinds (HsIPBinds binds) =
(addTickHsIPBinds binds)
addTickHsLocalBinds (EmptyLocalBinds) = return EmptyLocalBinds
-addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)
- -> TM (HsValBindsLR GhcTc (GhcPass b))
-addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do
- b <- liftM2 NValBinds
+addTickHsValBinds :: HsValBindsLR GhcTc a -> TM (HsValBindsLR GhcTc b)
+addTickHsValBinds (ValBindsOut binds sigs) =
+ liftM2 ValBindsOut
(mapM (\ (rec,binds') ->
liftM2 (,)
(return rec)
(addTickLHsBinds binds'))
binds)
(return sigs)
- return $ XValBindsLR b
addTickHsValBinds _ = panic "addTickHsValBinds"
addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)
@@ -830,11 +828,12 @@ addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)
addTickLPat pat = return pat
addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)
-addTickHsCmdTop (HsCmdTop x cmd) =
- liftM2 HsCmdTop
- (return x)
+addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
+ liftM4 HsCmdTop
(addTickLHsCmd cmd)
-addTickHsCmdTop (XCmdTop{}) = panic "addTickHsCmdTop"
+ (return tys)
+ (return ty)
+ (return syntaxtable)
addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd (L pos c0) = do
@@ -842,10 +841,10 @@ addTickLHsCmd (L pos c0) = do
return $ L pos c1
addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)
-addTickHsCmd (HsCmdLam x matchgroup) =
- liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup)
-addTickHsCmd (HsCmdApp x c e) =
- liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e)
+addTickHsCmd (HsCmdLam matchgroup) =
+ liftM HsCmdLam (addTickCmdMatchGroup matchgroup)
+addTickHsCmd (HsCmdApp c e) =
+ liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e)
{-
addTickHsCmd (OpApp e1 c2 fix c3) =
liftM4 OpApp
@@ -854,43 +853,41 @@ addTickHsCmd (OpApp e1 c2 fix c3) =
(return fix)
(addTickLHsCmd c3)
-}
-addTickHsCmd (HsCmdPar x e) = liftM (HsCmdPar x) (addTickLHsCmd e)
-addTickHsCmd (HsCmdCase x e mgs) =
- liftM2 (HsCmdCase x)
+addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e)
+addTickHsCmd (HsCmdCase e mgs) =
+ liftM2 HsCmdCase
(addTickLHsExpr e)
(addTickCmdMatchGroup mgs)
-addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =
- liftM3 (HsCmdIf x cnd)
+addTickHsCmd (HsCmdIf cnd e1 c2 c3) =
+ liftM3 (HsCmdIf cnd)
(addBinTickLHsExpr (BinBox CondBinBox) e1)
(addTickLHsCmd c2)
(addTickLHsCmd c3)
-addTickHsCmd (HsCmdLet x (L l binds) c) =
+addTickHsCmd (HsCmdLet (L l binds) c) =
bindLocals (collectLocalBinders binds) $
- liftM2 (HsCmdLet x . L l)
+ liftM2 (HsCmdLet . L l)
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsCmd c)
-addTickHsCmd (HsCmdDo srcloc (L l stmts))
+addTickHsCmd (HsCmdDo (L l stmts) srcloc)
= do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
- ; return (HsCmdDo srcloc (L l stmts')) }
+ ; return (HsCmdDo (L l stmts') srcloc) }
-addTickHsCmd (HsCmdArrApp arr_ty e1 e2 ty1 lr) =
+addTickHsCmd (HsCmdArrApp e1 e2 ty1 arr_ty lr) =
liftM5 HsCmdArrApp
- (return arr_ty)
(addTickLHsExpr e1)
(addTickLHsExpr e2)
(return ty1)
+ (return arr_ty)
(return lr)
-addTickHsCmd (HsCmdArrForm x e f fix cmdtop) =
- liftM4 (HsCmdArrForm x)
+addTickHsCmd (HsCmdArrForm e f fix cmdtop) =
+ liftM4 HsCmdArrForm
(addTickLHsExpr e)
(return f)
(return fix)
(mapM (liftL (addTickHsCmdTop)) cmdtop)
-addTickHsCmd (HsCmdWrap x w cmd)
- = liftM2 (HsCmdWrap x) (return w) (addTickHsCmd cmd)
-
-addTickHsCmd e@(XCmd {}) = pprPanic "addTickHsCmd" (ppr e)
+addTickHsCmd (HsCmdWrap w cmd)
+ = liftM2 HsCmdWrap (return w) (addTickHsCmd cmd)
-- Others should never happen in a command context.
--addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e)
@@ -1170,7 +1167,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 noExt tickish (L pos e)))
+ return (L pos (HsTick tickish (L pos e)))
) (do
e <- m
return (L pos e)
@@ -1256,14 +1253,13 @@ mkBinTickBoxHpc boxLabel pos e =
c = tickBoxCount st
mes = mixEntries st
in
- ( 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}
- )
+ ( 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}
+ )
mkHpcPos :: SrcSpan -> HpcPos
mkHpcPos pos@(RealSrcSpan s)
diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs
index 61dc7c5b5b..24d7d8a61c 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 (CmdTopTc _unitTy cmd_ty ids) cmd)) = do
+dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = 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,7 +328,6 @@ dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = 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
@@ -364,7 +363,7 @@ dsCmd :: DsCmdEnv -- arrow combinators
-- ---> premap (\ ((xs), _stk) -> arg) fun
dsCmd ids local_vars stack_ty res_ty
- (HsCmdArrApp arrow_ty arrow arg HsFirstOrderApp _)
+ (HsCmdArrApp arrow arg arrow_ty HsFirstOrderApp _)
env_ids = do
let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
@@ -389,7 +388,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_ty arrow arg HsHigherOrderApp _)
+ (HsCmdArrApp arrow arg arrow_ty HsHigherOrderApp _)
env_ids = do
let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
@@ -417,7 +416,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
@@ -450,7 +449,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)
@@ -480,7 +479,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
@@ -493,7 +492,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
@@ -554,8 +553,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
@@ -576,12 +575,10 @@ dsCmd ids local_vars stack_ty res_ty
left_con <- dsLookupDataCon leftDataConName
right_con <- dsLookupDataCon rightDataConName
let
- 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
+ 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
-- Prefix each tuple with a distinct series of Left's and Right's,
-- in a balanced way, keeping track of the types.
@@ -600,10 +597,9 @@ 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 noExt exp
- (MG { mg_alts = L l matches'
- , mg_arg_tys = arg_tys
- , mg_res_ty = sum_ty, mg_origin = origin }))
+ core_body <- dsExpr (HsCase 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'
@@ -617,8 +613,7 @@ 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
@@ -643,8 +638,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body)
--
-- ---> premap (\ (env,stk) -> env) c
-dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty (L loc stmts))
- env_ids = do
+dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo (L loc stmts) stmts_ty) env_ids = do
putSrcSpanDs loc $
dsNoLevPoly stmts_ty
(text "In the do-command:" <+> ppr do_block)
@@ -664,14 +658,14 @@ dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty (L loc stmts))
-- -----------------------------------
-- D; xs |-a (|e c1 ... cn|) :: stk --> t ---> e [t_xs] c1 ... cn
-dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do
+dsCmd _ids 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')
@@ -688,8 +682,7 @@ 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 (CmdTopTc stack_ty cmd_ty ids) cmd )) = do
+dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = 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
@@ -700,7 +693,6 @@ dsTrimCmdArg local_vars env_ids
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))
@@ -1195,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 (SigPat _ pat) = collectl pat bndrs
- go (CoPat _ _ pat _) = collectl (noLoc pat) bndrs
- go (ViewPat _ _ pat) = collectl pat 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 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 bba301c7ac..635a9c6137 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -78,9 +78,8 @@ dsLocalBinds (L _ (HsIPBinds binds)) body = dsIPBinds binds body
-------------------------
-- caller sets location
dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr
-dsValBinds (XValBindsLR (NValBinds binds _)) body
- = foldrM ds_val_bind body binds
-dsValBinds (ValBinds {}) _ = panic "dsValBinds ValBindsIn"
+dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
+dsValBinds (ValBindsIn {}) _ = panic "dsValBinds ValBindsIn"
-------------------------
dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
@@ -250,18 +249,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 _ (ExprWithTySig _ e) = dsLExpr e
-ds_expr w (HsVar _ (L _ var)) = dsHsVar w var
+ds_expr _ (HsPar e) = dsLExpr e
+ds_expr _ (ExprWithTySigOut 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 _ (XExpr {}) = panic "dsExpr: XExpr"
+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
; wrap' <- dsHsWrapper co_fn
; dflags <- getDynFlags
@@ -271,7 +269,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
@@ -280,23 +278,23 @@ 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 _ (HsAppType _ e)
+ds_expr _ (HsAppTypeOut e _)
-- ignore type arguments here; they're in the wrappers instead at this point
= dsLExpr e
@@ -340,19 +338,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)
@@ -363,32 +361,31 @@ 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 types alt arity expr)
+ds_expr _ (ExplicitSum alt arity expr types)
= 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
@@ -399,31 +396,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 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)
+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)
= do { pred <- dsLExpr guard_expr
; b1 <- dsLExpr then_expr
; b2 <- dsLExpr else_expr
@@ -456,7 +453,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
@@ -538,9 +535,8 @@ 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_flds = rbinds
- , rcon_ext = RecordConTc { rcon_con_expr = con_expr
- , rcon_con_like = con_like }})
+ds_expr _ (RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds
+ , rcon_con_like = con_like })
= do { con_expr' <- dsExpr con_expr
; let
(arg_tys, _) = tcSplitFunTys (exprType con_expr')
@@ -599,11 +595,9 @@ 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_ext = RecordUpdTc
- { rupd_cons = cons_to_upd
- , rupd_in_tys = in_inst_tys
- , rupd_out_tys = out_inst_tys
- , rupd_wrap = dict_req_wrap }} )
+ , 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
@@ -667,7 +661,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 noExt con)
+ inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut con)
-- Reconstruct with the WrapId so that unpacking happens
-- The order here is because of the order in `TcPatSyn`.
wrap = mkWpEvVarApps theta_vars <.>
@@ -719,16 +713,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')
@@ -739,19 +733,20 @@ 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,6 +754,7 @@ 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"
@@ -937,9 +933,9 @@ dsDo stmts
; rhss' <- sequence rhss
- ; let body' = noLoc $ HsDo body_ty DoExpr (noLoc stmts)
+ ; let body' = noLoc $ HsDo DoExpr (noLoc stmts) body_ty
- ; let fun = L noSrcSpan $ HsLam noExt $
+ ; let fun = L noSrcSpan $ HsLam $
MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats
body']
, mg_arg_tys = arg_tys
@@ -971,15 +967,15 @@ dsDo stmts
later_pats = rec_tup_pats
rets = map noLoc rec_rets
mfix_app = nlHsSyntaxApps mfix_op [mfix_arg]
- mfix_arg = noLoc $ HsLam noExt
+ mfix_arg = noLoc $ HsLam
(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 noExt $ mkBigLHsPatTupId rec_tup_pats
- body = noLoc $ HsDo body_ty
- DoExpr (noLoc (rec_stmts ++ [ret_stmt]))
+ mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTupId rec_tup_pats
+ body = noLoc $ HsDo
+ DoExpr (noLoc (rec_stmts ++ [ret_stmt])) body_ty
ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets]
ret_stmt = noLoc $ mkLastStmt ret_app
-- This LastStmt will be desugared with dsDo,
@@ -1141,9 +1137,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 4296630ba6..d521f537e5 100644
--- a/compiler/deSugar/DsGRHSs.hs
+++ b/compiler/deSugar/DsGRHSs.hs
@@ -136,25 +136,24 @@ 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 860c1baa14..fea637fafe 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,7 +90,6 @@ 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
@@ -106,8 +105,7 @@ 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 noExt stmts
- from_bndrs noSyntaxExpr)
+ (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock 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
@@ -255,7 +253,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
@@ -625,15 +623,13 @@ 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
@@ -642,7 +638,6 @@ 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'
--
@@ -782,7 +777,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
@@ -793,10 +788,9 @@ 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 c910fbf15b..2a181e8d16 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -77,14 +77,13 @@ 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 (XBracket {}) = panic "dsBracket: unexpected XBracket"
+ 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 }
{- -------------- Examples --------------------
@@ -199,8 +198,8 @@ hsSigTvBinders binds
get_scoped_tvs _ = []
sigs = case binds of
- ValBinds _ _ sigs -> sigs
- XValBindsLR (NValBinds _ sigs) -> sigs
+ ValBindsIn _ sigs -> sigs
+ ValBindsOut _ sigs -> sigs
{- Notes
@@ -696,7 +695,7 @@ repBangTy ty = do
rep2 bangTypeName [b, t]
where
(su', ss', ty') = case ty of
- L _ (HsBangTy _ (HsSrcBang _ su ss) ty) -> (su, ss, ty)
+ L _ (HsBangTy (HsSrcBang _ su ss) ty) -> (su, ss, ty)
_ -> (NoSrcUnpack, NoSrcStrict, ty)
-------------------------------------------------------
@@ -918,20 +917,18 @@ 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 _ (XTyVarBndr{})) = panic "repTyVarBndr"
+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' }
-- represent a type context
--
@@ -1003,7 +1000,7 @@ repTy :: HsType GhcRn -> DsM (Core TH.TypeQ)
repTy ty@(HsForAllTy {}) = repForall ty
repTy ty@(HsQualTy {}) = repForall ty
-repTy (HsTyVar _ _ (L _ n))
+repTy (HsTyVar _ (L _ n))
| isLiftedTypeKindTyConName n = repTStar
| n `hasKey` constraintKindTyConKey = repTConstraint
| isTvOcc occ = do tv1 <- lookupOcc n
@@ -1016,47 +1013,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 noExt NotPromoted
+ tcon <- repTy (HsTyVar 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
@@ -1064,9 +1061,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)
@@ -1100,11 +1097,10 @@ 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 e@(XSplice {}) = 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)
rep_splice :: Name -> DsM (Core a)
rep_splice splice_name
@@ -1129,7 +1125,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
@@ -1137,46 +1133,45 @@ 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 noExt (noLoc x))
+repE e@(HsRecFld f) = case f of
+ Unambiguous _ x -> repE (HsVar (noLoc x))
Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e)
- XAmbiguousFieldOcc{} -> notHandled "XAmbiguous record selectors" (ppr e)
-- Remember, we're desugaring renamer output here, so
-- HsOverlit can definitely occur
-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 t e) = do { a <- repLE e
+repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
+repE (HsAppType e t) = 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
@@ -1185,13 +1180,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);
@@ -1207,13 +1202,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 }
@@ -1226,7 +1221,7 @@ repE (RecordUpd { rupd_expr = e, rupd_flds = flds })
fs <- repUpdFields flds;
repRecUpd x fs }
-repE (ExprWithTySig ty e)
+repE (ExprWithTySig e ty)
= do { e1 <- repLE e
; t1 <- repHsSigWcType ty
; repSigExp e1 t1 }
@@ -1248,9 +1243,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
@@ -1259,6 +1254,7 @@ 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)
-----------------------------------------------------------------------------
@@ -1322,7 +1318,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)
@@ -1386,11 +1382,10 @@ 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
@@ -1425,12 +1420,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 (XValBindsLR (NValBinds binds sigs))
+rep_val_binds (ValBindsOut binds sigs)
= do { core1 <- rep_binds' (unionManyBags (map snd binds))
; core2 <- rep_sigs' sigs
; return (core1 ++ core2) }
-rep_val_binds (ValBinds _ _ _)
- = panic "rep_val_binds: ValBinds"
+rep_val_binds (ValBindsIn _ _)
+ = panic "rep_val_binds: ValBindsIn"
rep_binds :: LHsBinds GhcRn -> DsM [Core TH.DecQ]
rep_binds binds = do { binds_w_locs <- rep_binds' binds
@@ -1616,23 +1611,19 @@ 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 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)
+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 _)
| 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
@@ -1649,13 +1640,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 (SigPat t p) = 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 (SigPatIn p t) = do { p' <- repLP p
+ ; t' <- repLTy (hsSigWcType t)
+ ; repPsig p' t' }
+repP (SplicePat splice) = repSplice splice
repP other = notHandled "Exotic pattern" (ppr other)
@@ -2206,7 +2197,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 (extFieldOcc $ unLoc n)
+ rep_one_ip t n = do { MkC v <- lookupOcc (selectorFieldOcc $ unLoc n)
; MkC ty <- repBangTy t
; rep2 varBangTypeName [v,ty] }
@@ -2366,7 +2357,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 noExt r rat_ty
+ return $ HsRat def r rat_ty
mk_string :: FastString -> DsM (HsLit GhcRn)
mk_string s = return $ HsString noSourceText s
@@ -2379,7 +2370,6 @@ 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 f4fe8de227..3748193a19 100644
--- a/compiler/deSugar/DsUtils.hs
+++ b/compiler/deSugar/DsUtils.hs
@@ -9,8 +9,6 @@ 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 (
@@ -119,13 +117,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...
{-
@@ -738,7 +736,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)
@@ -785,17 +783,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)
@@ -805,10 +803,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
{- *********************************************************************
@@ -830,7 +828,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 (map hsLPatType pats) pats box
+mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats)
-- The Big equivalents for the source tuple expressions
mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc
@@ -985,8 +983,8 @@ mkBinaryTickBox ixT ixF e = do
-- pat => !pat -- when -XStrict
-- pat => pat -- otherwise
decideBangHood :: DynFlags
- -> LPat GhcTc -- ^ Original pattern
- -> LPat GhcTc -- Pattern with bang if necessary
+ -> LPat id -- ^ Original pattern
+ -> LPat id -- Pattern with bang if necessary
decideBangHood dflags lpat
| not (xopt LangExt.Strict dflags)
= lpat
@@ -995,20 +993,19 @@ decideBangHood dflags lpat
where
go lp@(L l p)
= case p of
- ParPat x p -> L l (ParPat x (go p))
- LazyPat _ lp' -> lp'
- BangPat _ _ -> lp
- _ -> L l (BangPat noExt lp)
+ ParPat p -> L l (ParPat (go p))
+ LazyPat lp' -> lp'
+ BangPat _ -> lp
+ _ -> L l (BangPat lp)
-- | Unconditionally make a 'Pat' strict.
-addBang :: LPat GhcTc -- ^ Original pattern
- -> LPat GhcTc -- ^ Banged pattern
+addBang :: LPat id -- ^ Original pattern
+ -> LPat id -- ^ Banged pattern
addBang = go
where
go lp@(L l p)
= case p of
- 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)
+ ParPat p -> L l (ParPat (go p))
+ LazyPat lp' -> L l (BangPat lp')
+ BangPat _ -> lp
+ _ -> L l (BangPat lp)
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index 4cb8bf35ba..7a3ee6853c 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 x pats ty (Just _)) = ListPat x pats ty Nothing
+getOLPat (ListPat pats ty (Just _)) = ListPat 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 (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
+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
-- 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 ty pats)
+tidy1 _ (PArrPat pats ty)
= return (idDsWrapper, unLoc parrConPat)
where
arity = length pats
parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty]
-tidy1 _ (TuplePat tys pats boxity)
+tidy1 _ (TuplePat pats boxity tys)
= return (idDsWrapper, unLoc tuple_ConPat)
where
arity = length pats
tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys
-tidy1 _ (SumPat tys pat alt arity)
+tidy1 _ (SumPat pat alt arity tys)
= 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 ty (L _ lit) mb_neg eq)
+tidy1 _ (NPat (L _ lit) mb_neg eq ty)
= return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq ty)
-- Everything else goes through unchanged...
@@ -484,14 +484,13 @@ 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 _ (SigPat _ (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 _ (SigPatOut (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 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)
+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)
-- Discard bang around strict pattern
tidy_bang_pat v _ p@(LitPat {}) = tidy1 v p
@@ -527,7 +526,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 noExt (L l p))
+tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p))
-------------------
push_bang_into_newtype_arg :: SrcSpan
@@ -538,16 +537,15 @@ 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 noExt arg)]
+ PrefixCon [L l (BangPat 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 noExt arg) })] })
+ RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg = L l (BangPat arg) })] })
push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})
| HsRecFields { rec_flds = [] } <- rf
- = PrefixCon [L l (BangPat noExt (noLoc (WildPat ty)))]
+ = PrefixCon [L l (BangPat (noLoc (WildPat ty)))]
push_bang_into_newtype_arg _ _ cd
= pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)
@@ -977,18 +975,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',
@@ -996,20 +994,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
@@ -1031,8 +1029,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
---------
@@ -1073,7 +1071,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))
@@ -1081,15 +1079,14 @@ 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 c7bff64ff3..355927deef 100644
--- a/compiler/deSugar/MatchLit.hs
+++ b/compiler/deSugar/MatchLit.hs
@@ -102,8 +102,6 @@ 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
@@ -112,12 +110,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_ext = OverLitTc rebindable ty
- , ol_witness = witness })
+dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable
+ , ol_witness = witness, ol_type = ty })
| 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]
~~~~~~~~~~~~~~~~~~~~~~~~
@@ -241,14 +239,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_ext = OverLitTc _ ty })
+getIntegralLit (OverLit { ol_val = HsIntegral i, ol_type = ty })
| Just tc <- tyConAppTyCon_maybe ty
= Just (il_value i, tyConName tc)
getIntegralLit _ = Nothing
@@ -275,7 +273,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 noExt lit
+tidyLitPat lit = LitPat lit
----------------
tidyNPat :: (HsLit GhcTc -> Pat GhcTc) -- How to tidy a LitPat
@@ -286,7 +284,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 (OverLitTc False ty) val _) mb_neg _eq outer_ty
+tidyNPat tidy_lit_pat (OverLit val False _ ty) 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
@@ -315,8 +313,7 @@ tidyNPat tidy_lit_pat (OverLit (OverLitTc False ty) val _) 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 noExt lit] [])
+ mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] [])
mb_int_lit :: Maybe Integer
mb_int_lit = case (mb_neg, val) of
@@ -330,7 +327,7 @@ tidyNPat tidy_lit_pat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty
_ -> Nothing
tidyNPat _ over_lit mb_neg eq outer_ty
- = NPat outer_ty (noLoc over_lit) mb_neg eq
+ = NPat (noLoc over_lit) mb_neg eq outer_ty
{-
************************************************************************
@@ -364,7 +361,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)
@@ -412,7 +409,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
@@ -443,7 +440,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]
@@ -455,7 +452,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 f008a31d4b..aa1bc814c5 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 _ mb_ol elems)
+hsExprToPmExpr e@(ExplicitList _elem_ty 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 _ elems)
+hsExprToPmExpr (ExplicitPArr _elem_ty elems)
= mkPmExprData (parrFakeCon (length elems)) (map lhsExprToPmExpr elems)
@@ -272,15 +272,16 @@ hsExprToPmExpr (ExplicitPArr _ 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 (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 (ExprWithTySigOut 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