summaryrefslogtreecommitdiff
path: root/compiler/deSugar
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/deSugar')
-rw-r--r--compiler/deSugar/Coverage.hs17
-rw-r--r--compiler/deSugar/DsArrows.hs2
-rw-r--r--compiler/deSugar/DsBinds.hs2
-rw-r--r--compiler/deSugar/DsExpr.hs6
-rw-r--r--compiler/deSugar/DsMeta.hs2
-rw-r--r--compiler/deSugar/DsUtils.hs29
-rw-r--r--compiler/deSugar/Match.hs4
7 files changed, 47 insertions, 15 deletions
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index b7bed75f3d..d73b5047a8 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -628,10 +628,10 @@ addTickHsExpr (HsProc x pat cmdtop) =
liftM2 (HsProc x)
(addTickLPat pat)
(liftL (addTickHsCmdTop) cmdtop)
-addTickHsExpr (HsWrap x w e) =
- liftM2 (HsWrap x)
- (return w)
- (addTickHsExpr e) -- Explicitly no tick on inside
+addTickHsExpr (XExpr (HsWrap w e)) =
+ liftM XExpr $
+ liftM (HsWrap w)
+ (addTickHsExpr e) -- Explicitly no tick on inside
-- Others should never happen in expression content.
addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e)
@@ -832,6 +832,8 @@ addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do
x' <- fmap unLoc (addTickLHsExpr (cL pos x))
return $ syn { syn_expr = x' }
+addTickSyntaxExpr _ NoSyntaxExpr = return NoSyntaxExpr
+
-- we do not walk into patterns.
addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)
addTickLPat pat = return pat
@@ -894,10 +896,9 @@ addTickHsCmd (HsCmdArrForm x e f fix cmdtop) =
(return fix)
(mapM (liftL (addTickHsCmdTop)) cmdtop)
-addTickHsCmd (HsCmdWrap x w cmd)
- = liftM2 (HsCmdWrap x) (return w) (addTickHsCmd cmd)
-
-addTickHsCmd (XCmd nec) = noExtCon nec
+addTickHsCmd (XCmd (HsWrap w cmd)) =
+ liftM XCmd $
+ liftM (HsWrap w) (addTickHsCmd cmd)
-- Others should never happen in a command context.
--addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e)
diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs
index ade017208d..0a049513ff 100644
--- a/compiler/deSugar/DsArrows.hs
+++ b/compiler/deSugar/DsArrows.hs
@@ -688,7 +688,7 @@ dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do
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 (XCmd (HsWrap 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')
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 6498ed7f6f..e1f1628b57 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -145,7 +145,7 @@ dsHsBind dflags (VarBind { var_id = var
dsHsBind dflags b@(FunBind { fun_id = (dL->L _ fun)
, fun_matches = matches
- , fun_co_fn = co_fn
+ , fun_ext = co_fn
, fun_tick = tick })
= do { (args, body) <- matchWrapper
(mkPrefixFunRhs (noLoc $ idName fun))
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 1cf981cddd..724b00851b 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -194,7 +194,7 @@ dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
dsUnliftedBind (FunBind { fun_id = (dL->L l fun)
, fun_matches = matches
- , fun_co_fn = co_fn
+ , fun_ext = co_fn
, fun_tick = tick }) body
-- Can't be a bang pattern (that looks like a PatBind)
-- so must be simply unboxed
@@ -274,7 +274,7 @@ ds_expr _ (HsOverLit _ lit)
= do { warnAboutOverflowedOverLit lit
; dsOverLit lit }
-ds_expr _ (HsWrap _ co_fn e)
+ds_expr _ (XExpr (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
@@ -755,7 +755,6 @@ ds_expr _ (HsTickPragma _ _ _ _ expr) = do
ds_expr _ (HsBracket {}) = panic "dsExpr:HsBracket"
ds_expr _ (HsDo {}) = panic "dsExpr:HsDo"
ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld"
-ds_expr _ (XExpr nec) = noExtCon nec
------------------------------
@@ -772,6 +771,7 @@ dsSyntaxExpr (SyntaxExpr { syn_expr = expr
(\_ -> core_res_wrap (mkApps fun wrapped_args)) }
where
mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr)
+dsSyntaxExpr NoSyntaxExpr _ = panic "dsSyntaxExpr"
findField :: [LHsRecField GhcTc arg] -> Name -> [arg]
findField rbinds sel
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 7baa748faa..f3144e141a 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1818,7 +1818,7 @@ repP (AsPat _ x p) = do { x' <- lookupLBinder x; p1 <- repLP p
repP (ParPat _ p) = repLP p
repP (ListPat Nothing ps) = do { qs <- repLPs ps; repPlist qs }
repP (ListPat (Just e) ps) = do { p <- repP (ListPat Nothing ps)
- ; e' <- repE (syn_expr e)
+ ; e' <- repE (expectJust "repP" e)
; repPview e' p}
repP (TuplePat _ ps boxed)
| isBoxed boxed = do { qs <- repLPs ps; repPtup qs }
diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs
index 8559e9ae85..52444c13f7 100644
--- a/compiler/deSugar/DsUtils.hs
+++ b/compiler/deSugar/DsUtils.hs
@@ -37,6 +37,8 @@ module DsUtils (
mkSelectorBinds,
+ mkPrefixConPat, mkCharLitPat, mkNilPat,
+
selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang,
isTrueLHsExpr
@@ -777,6 +779,33 @@ mkBigLHsPatTupId = mkChunkified mkLHsPatTup
{-
************************************************************************
* *
+* Building patterns
+* *
+************************************************************************
+-}
+
+mkPrefixConPat :: DataCon ->
+ [OutPat (GhcPass p)] -> [Type] -> OutPat (GhcPass p)
+-- Make a vanilla Prefix constructor pattern
+mkPrefixConPat dc pats tys
+ = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc)
+ , pat_tvs = []
+ , pat_dicts = []
+ , pat_binds = emptyTcEvBinds
+ , pat_args = PrefixCon pats
+ , pat_arg_tys = tys
+ , pat_wrap = idHsWrapper }
+
+mkNilPat :: Type -> OutPat (GhcPass p)
+mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
+
+mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p)
+mkCharLitPat src c = mkPrefixConPat charDataCon
+ [noLoc $ LitPat noExtField (HsCharPrim src c)] []
+
+{-
+************************************************************************
+* *
Code for pattern-matching and other failures
* *
************************************************************************
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index 2e0aeb9877..7097d863de 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -1008,7 +1008,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
exp e (HsPar _ (dL->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 (XExpr (HsWrap h e)) (XExpr (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
@@ -1056,6 +1056,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
= exp expr1 expr2 &&
and (zipWithEqual "viewLExprEq" wrap arg_wraps1 arg_wraps2) &&
wrap res_wrap1 res_wrap2
+ syn_exp NoSyntaxExpr NoSyntaxExpr = True
+ syn_exp _ _ = False
---------
tup_arg (dL->L _ (Present _ e1)) (dL->L _ (Present _ e2)) = lexp e1 e2
View Lorry Controller Status