summaryrefslogtreecommitdiff
path: root/compiler/GHC/HsToCore
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/HsToCore')
-rw-r--r--compiler/GHC/HsToCore/Docs.hs2
-rw-r--r--compiler/GHC/HsToCore/Expr.hs2
-rw-r--r--compiler/GHC/HsToCore/Match.hs6
-rw-r--r--compiler/GHC/HsToCore/Match/Constructor.hs4
-rw-r--r--compiler/GHC/HsToCore/Pmc/Desugar.hs2
-rw-r--r--compiler/GHC/HsToCore/Quote.hs15
6 files changed, 16 insertions, 15 deletions
diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs
index 72e4fe99c3..0f80c61d65 100644
--- a/compiler/GHC/HsToCore/Docs.hs
+++ b/compiler/GHC/HsToCore/Docs.hs
@@ -220,7 +220,7 @@ conArgDocs (ConDeclGADT{con_g_args = args, con_res_ty = res_ty}) =
h98ConArgDocs :: HsConDeclH98Details GhcRn -> Map Int HsDocString
h98ConArgDocs con_args = case con_args of
- PrefixCon args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args
+ PrefixCon _ args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args
InfixCon arg1 arg2 -> con_arg_docs 0 [ unLoc (hsScaledThing arg1)
, unLoc (hsScaledThing arg2) ]
RecCon _ -> M.empty
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index c1479d7c9a..c7eeaec586 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -822,7 +822,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys
pat = noLoc $ ConPat { pat_con = noLoc con
- , pat_args = PrefixCon $ map nlVarPat arg_ids
+ , pat_args = PrefixCon [] $ map nlVarPat arg_ids
, pat_con_ext = ConPatTc
{ cpt_tvs = ex_tvs
, cpt_dicts = eqs_vars ++ theta_vars
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index 12c9a49278..bd48a19024 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -573,9 +573,9 @@ push_bang_into_newtype_arg :: SrcSpan
-> HsConPatDetails GhcTc -> HsConPatDetails GhcTc
-- See Note [Bang patterns and newtypes]
-- We are transforming !(N p) into (N !p)
-push_bang_into_newtype_arg l _ty (PrefixCon (arg:args))
+push_bang_into_newtype_arg l _ty (PrefixCon ts (arg:args))
= ASSERT( null args)
- PrefixCon [L l (BangPat noExtField arg)]
+ PrefixCon ts [L l (BangPat noExtField arg)]
push_bang_into_newtype_arg l _ty (RecCon rf)
| HsRecFields { rec_flds = L lf fld : flds } <- rf
, HsRecField { hsRecFieldArg = arg } <- fld
@@ -584,7 +584,7 @@ push_bang_into_newtype_arg l _ty (RecCon rf)
= L l (BangPat noExtField arg) })] })
push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})
| HsRecFields { rec_flds = [] } <- rf
- = PrefixCon [L l (BangPat noExtField (noLoc (WildPat ty)))]
+ = PrefixCon [] [L l (BangPat noExtField (noLoc (WildPat ty)))]
push_bang_into_newtype_arg _ _ cd
= pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)
diff --git a/compiler/GHC/HsToCore/Match/Constructor.hs b/compiler/GHC/HsToCore/Match/Constructor.hs
index ca6ad7f483..39817044cc 100644
--- a/compiler/GHC/HsToCore/Match/Constructor.hs
+++ b/compiler/GHC/HsToCore/Match/Constructor.hs
@@ -248,7 +248,7 @@ same_fields flds1 flds2
selectConMatchVars :: [Scaled Type] -> ConArgPats -> DsM [Id]
selectConMatchVars arg_tys con = case con of
(RecCon {}) -> newSysLocalsDsNoLP arg_tys
- (PrefixCon ps) -> selectMatchVars (zipMults arg_tys ps)
+ (PrefixCon _ ps) -> selectMatchVars (zipMults arg_tys ps)
(InfixCon p1 p2) -> selectMatchVars (zipMults arg_tys [p1, p2])
where
zipMults = zipWithEqual "selectConMatchVar" (\a b -> (scaledMult a, unLoc b))
@@ -258,7 +258,7 @@ conArgPats :: [Scaled Type]-- Instantiated argument types
-- are probably never looked at anyway
-> ConArgPats
-> [Pat GhcTc]
-conArgPats _arg_tys (PrefixCon ps) = map unLoc ps
+conArgPats _arg_tys (PrefixCon _ ps) = map unLoc ps
conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2]
conArgPats arg_tys (RecCon (HsRecFields { rec_flds = rpats }))
| null rpats = map WildPat (map scaledThing arg_tys)
diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs
index 98b23dab25..1abe0fc9dc 100644
--- a/compiler/GHC/HsToCore/Pmc/Desugar.hs
+++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs
@@ -255,7 +255,7 @@ desugarListPat x pats = do
desugarConPatOut :: Id -> ConLike -> [Type] -> [TyVar]
-> [EvVar] -> HsConPatDetails GhcTc -> DsM [PmGrd]
desugarConPatOut x con univ_tys ex_tvs dicts = \case
- PrefixCon ps -> go_field_pats (zip [0..] ps)
+ PrefixCon _ ps -> go_field_pats (zip [0..] ps)
InfixCon p1 p2 -> go_field_pats (zip [0..] [p1,p2])
RecCon (HsRecFields fs _) -> go_field_pats (rec_field_ps fs)
where
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 7f2d0b5d85..7f675e8253 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -1884,7 +1884,7 @@ rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn
-- their pattern-only bound right hand sides have different names,
-- we want to treat them the same in TH. This is the reason why we
-- need an adjusted mkGenArgSyms in the `RecCon` case below.
- mkGenArgSyms (PrefixCon args) = mkGenSyms (map unLoc args)
+ mkGenArgSyms (PrefixCon _ args) = mkGenSyms (map unLoc args)
mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]
mkGenArgSyms (RecCon fields)
= do { let pats = map (unLoc . recordPatSynPatVar) fields
@@ -1910,7 +1910,7 @@ repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat)
= rep2 patSynDName [syn, args, dir, pat]
repPatSynArgs :: HsPatSynDetails GhcRn -> MetaM (Core (M TH.PatSynArgs))
-repPatSynArgs (PrefixCon args)
+repPatSynArgs (PrefixCon _ args)
= do { args' <- repList nameTyConName lookupLOcc args
; repPrefixPatSynArgs args' }
repPatSynArgs (InfixCon arg1 arg2)
@@ -2016,7 +2016,9 @@ repP (SumPat _ p alt arity) = do { p1 <- repLP p
repP (ConPat NoExtField dc details)
= do { con_str <- lookupLOcc dc
; case details of
- PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
+ PrefixCon tyargs ps -> do { qs <- repLPs ps
+ ; ts <- repListM typeTyConName (repTy . unLoc . hsps_body) tyargs
+ ; repPcon con_str ts qs }
RecCon rec -> do { fps <- repListM fieldPatTyConName rep_fld (rec_flds rec)
; repPrec con_str fps }
InfixCon p1 p2 -> do { p1' <- repLP p1;
@@ -2028,7 +2030,6 @@ repP (ConPat NoExtField dc details)
rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)
; 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' }
@@ -2249,8 +2250,8 @@ repPunboxedSum (MkC p) alt arity
, mkIntExprInt platform alt
, mkIntExprInt platform arity ] }
-repPcon :: Core TH.Name -> Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))
-repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
+repPcon :: Core TH.Name -> Core [(M TH.Type)] -> Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))
+repPcon (MkC s) (MkC ts) (MkC ps) = rep2 conPName [s, ts, ps]
repPrec :: Core TH.Name -> Core [M (TH.Name, TH.Pat)] -> MetaM (Core (M TH.Pat))
repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
@@ -2621,7 +2622,7 @@ repH98DataCon :: Located Name
repH98DataCon con details
= do con' <- lookupLOcc con -- See Note [Binders and occurrences]
case details of
- PrefixCon ps -> do
+ PrefixCon _ ps -> do
arg_tys <- repPrefixConArgs ps
rep2 normalCName [unC con', unC arg_tys]
InfixCon st1 st2 -> do
View Lorry Controller Status