summaryrefslogtreecommitdiff
path: root/compiler/deSugar
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/deSugar')
-rw-r--r--compiler/deSugar/Check.lhs4
-rw-r--r--compiler/deSugar/Coverage.lhs4
-rw-r--r--compiler/deSugar/Desugar.lhs2
-rw-r--r--compiler/deSugar/DsExpr.lhs20
-rw-r--r--compiler/deSugar/DsMeta.hs4
-rw-r--r--compiler/deSugar/DsMonad.lhs1
-rw-r--r--compiler/deSugar/MatchCon.lhs4
7 files changed, 22 insertions, 17 deletions
diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs
index 3e6912f20e..5f55c7a7aa 100644
--- a/compiler/deSugar/Check.lhs
+++ b/compiler/deSugar/Check.lhs
@@ -763,9 +763,9 @@ tidy_con con (RecCon (HsRecFields fs _))
-- pad out all the missing fields with WildPats.
field_pats = case con of
- RealDataCon dc -> map (\ f -> (f, nlWildPatId)) (dataConFieldLabels dc)
+ RealDataCon dc -> map (\ f -> (flSelector f, nlWildPatId)) (dataConFieldLabels dc)
PatSynCon{} -> panic "Check.tidy_con: pattern synonym with record syntax"
- all_pats = foldr (\(HsRecField id p _) acc -> insertNm (getName (unLoc id)) p acc)
+ all_pats = foldr (\ x acc -> insertNm (getName (unLoc (hsRecFieldId x))) (hsRecFieldArg x) acc)
field_pats fs
insertNm nm p [] = [(nm,p)]
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 5e7289f00c..a049350607 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -891,9 +891,9 @@ addTickHsRecordBinds (HsRecFields fields dd)
= do { fields' <- mapM process fields
; return (HsRecFields fields' dd) }
where
- process (HsRecField ids expr doc)
+ process (HsRecField lbl sel expr doc)
= do { expr' <- addTickLHsExpr expr
- ; return (HsRecField ids expr' doc) }
+ ; return (HsRecField lbl sel expr' doc) }
addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
addTickArithSeqInfo (From e1) =
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index 3160b35f15..5da3b1ca37 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -91,6 +91,7 @@ deSugar hsc_env
tcg_tcs = tcs,
tcg_insts = insts,
tcg_fam_insts = fam_insts,
+ tcg_axioms = axioms,
tcg_hpc = other_hpc_info })
= do { let dflags = hsc_dflags hsc_env
@@ -178,6 +179,7 @@ deSugar hsc_env
mg_tcs = tcs,
mg_insts = insts,
mg_fam_insts = fam_insts,
+ mg_axioms = axioms,
mg_inst_env = inst_env,
mg_fam_inst_env = fam_inst_env,
mg_patsyns = filter ((`elemNameSet` export_set) . patSynName) patsyns,
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 6844f48970..e1bf160b3f 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -22,6 +22,7 @@ import DsArrows
import DsMonad
import Name
import NameEnv
+import RdrName
import FamInstEnv( topNormaliseType )
#ifdef GHCI
@@ -421,11 +422,11 @@ dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
-- A newtype in the corner should be opaque;
-- hence TcType.tcSplitFunTys
- mk_arg (arg_ty, lbl) -- Selector id has the field label as its name
- = case findField (rec_flds rbinds) lbl of
+ mk_arg (arg_ty, fl)
+ = case findField (rec_flds rbinds) (flLabel fl) of
(rhs:rhss) -> ASSERT( null rhss )
dsLExpr rhs
- [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl)
+ [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))
unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty
labels = dataConFieldLabels (idDataCon data_con_id)
@@ -525,8 +526,8 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
; arg_ids <- newSysLocalsDs (substTys subst arg_tys)
; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
(dataConFieldLabels con) arg_ids
- mk_val_arg field_name pat_arg_id
- = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
+ mk_val_arg fl pat_arg_id
+ = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id)
inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
-- Reconstruct with the WrapId so that unpacking happens
wrap = mkWpEvVarApps theta_vars <.>
@@ -611,12 +612,13 @@ dsExpr (EViewPat {}) = panic "dsExpr:EViewPat"
dsExpr (ELazyPat {}) = panic "dsExpr:ELazyPat"
dsExpr (HsType {}) = panic "dsExpr:HsType"
dsExpr (HsDo {}) = panic "dsExpr:HsDo"
+dsExpr (HsOverloadedRecFld {}) = panic "dsExpr: HsOverloadedRecFld"
+dsExpr (HsSingleRecFld {}) = panic "dsExpr: HsOverloadedRecFld"
-findField :: [HsRecField Id arg] -> Name -> [arg]
-findField rbinds lbl
- = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds
- , lbl == idName (unLoc id) ]
+findField :: [HsRecField Id arg] -> FieldLabelString -> [arg]
+findField rbinds lbl
+ = [hsRecFieldArg x | x <- rbinds, occNameFS (rdrNameOcc (unLoc (hsRecFieldLbl x))) == lbl]
\end{code}
%--------------------------------------------------------------------
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 28e6feffec..abcac56ab8 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -63,8 +63,8 @@ import DynFlags
import FastString
import ForeignCall
import Util
+import Maybes
-import Data.Maybe
import Control.Monad
import Data.List
@@ -114,7 +114,7 @@ repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
repTopDs group
= do { let { tv_bndrs = hsSigTvBinders (hs_valds group)
- ; bndrs = tv_bndrs ++ hsGroupBinders group } ;
+ ; bndrs = tv_bndrs ++ fst (hsGroupBinders group) } ;
ss <- mkGenSyms bndrs ;
-- Bind all the names mainly to avoid repeated use of explicit strings.
diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs
index c017a7cc01..a1c1900566 100644
--- a/compiler/deSugar/DsMonad.lhs
+++ b/compiler/deSugar/DsMonad.lhs
@@ -47,6 +47,7 @@ import TcIface
import LoadIface
import Finder
import PrelNames
+import RnNames
import RdrName
import HscTypes
import Bag
diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs
index 611d48e456..9fbe08124d 100644
--- a/compiler/deSugar/MatchCon.lhs
+++ b/compiler/deSugar/MatchCon.lhs
@@ -139,7 +139,7 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor
pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }
= firstPat eqn1
fields1 = case con1 of
- RealDataCon dcon1 -> dataConFieldLabels dcon1
+ RealDataCon dcon1 -> map flSelector $ dataConFieldLabels dcon1
PatSynCon{} -> []
val_arg_tys = case con1 of
@@ -203,7 +203,7 @@ compatible_pats _ _ = True -- Prefix or infix co
same_fields :: HsRecFields Id (LPat Id) -> HsRecFields Id (LPat Id) -> Bool
same_fields flds1 flds2
- = all2 (\f1 f2 -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))
+ = all2 (\f1 f2 -> hsRecFieldSel f1 == hsRecFieldSel f2)
(rec_flds flds1) (rec_flds flds2)
View Lorry Controller Status