summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/basicTypes/Id.hs11
-rw-r--r--compiler/basicTypes/IdInfo.hs3
-rw-r--r--compiler/deSugar/Coverage.hs5
-rw-r--r--compiler/deSugar/DsExpr.hs4
-rw-r--r--compiler/deSugar/DsMeta.hs2
-rw-r--r--compiler/hsSyn/Convert.hs4
-rw-r--r--compiler/hsSyn/HsExpr.hs4
-rw-r--r--compiler/hsSyn/PlaceHolder.hs2
-rw-r--r--compiler/parser/RdrHsSyn.hs4
-rw-r--r--compiler/rename/RnExpr.hs6
-rw-r--r--compiler/typecheck/TcExpr.hs5
-rw-r--r--compiler/typecheck/TcHsSyn.hs4
-rw-r--r--compiler/typecheck/TcPatSyn.hs14
13 files changed, 30 insertions, 38 deletions
diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs
index e22a77c07c..b49a8160fe 100644
--- a/compiler/basicTypes/Id.hs
+++ b/compiler/basicTypes/Id.hs
@@ -60,7 +60,7 @@ module Id (
isPrimOpId, isPrimOpId_maybe,
isFCallId, isFCallId_maybe,
isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon,
- idConLike, isConLikeId, isBottomingId, idIsFrom,
+ isConLikeId, isBottomingId, idIsFrom,
hasNoBinding,
-- ** Evidence variables
@@ -133,7 +133,6 @@ import UniqSupply
import FastString
import Util
import StaticFlags
-import {-# SOURCE #-} ConLike ( ConLike(..) )
-- infixl so you can say (id `set` a `set` b)
infixl 1 `setIdUnfoldingLazily`,
@@ -437,14 +436,6 @@ idDataCon :: Id -> DataCon
-- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker
idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id)
-idConLike :: Id -> ConLike
-idConLike id =
- case Var.idDetails id of
- DataConWorkId con -> RealDataCon con
- DataConWrapId con -> RealDataCon con
- PatSynBuilderId ps -> PatSynCon ps
- _ -> pprPanic "idConLike" (ppr id)
-
hasNoBinding :: Id -> Bool
-- ^ Returns @True@ of an 'Id' which may not have a
-- binding, even though it is defined in this module.
diff --git a/compiler/basicTypes/IdInfo.hs b/compiler/basicTypes/IdInfo.hs
index ea1eb19c35..94d34419a2 100644
--- a/compiler/basicTypes/IdInfo.hs
+++ b/compiler/basicTypes/IdInfo.hs
@@ -122,8 +122,6 @@ data IdDetails
-- a) to support isImplicitId
-- b) when desugaring a RecordCon we can get
-- from the Id back to the data con]
- | PatSynBuilderId PatSyn -- ^ As for DataConWrapId
-
| ClassOpId Class -- ^ The 'Id' is a superclass selector,
-- or class operation of a class
@@ -188,7 +186,6 @@ pprIdDetails other = brackets (pp other)
pp (RecSelId { sel_naughty = is_naughty })
= brackets $ ptext (sLit "RecSel")
<> ppWhen is_naughty (ptext (sLit "(naughty)"))
- pp (PatSynBuilderId _) = ptext (sLit "PatSynBuilder")
{-
************************************************************************
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index dfe3807b1a..0678acec97 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -535,11 +535,12 @@ addTickHsExpr (ExplicitPArr ty es) =
addTickHsExpr (HsStatic e) = HsStatic <$> addTickLHsExpr e
-addTickHsExpr (RecordCon id ty rec_binds) =
- liftM3 RecordCon
+addTickHsExpr (RecordCon id ty rec_binds labels) =
+ liftM4 RecordCon
(return id)
(return ty)
(addTickHsRecordBinds rec_binds)
+ (return labels)
addTickHsExpr (RecordUpd e rec_binds cons tys1 tys2 req_wrap) =
return RecordUpd `ap`
(addTickLHsExpr e) `ap`
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 2f7ebd85c0..075a647588 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -493,7 +493,7 @@ We also handle @C{}@ as valid construction syntax for an unlabelled
constructor @C@, setting all of @C@'s fields to bottom.
-}
-dsExpr (RecordCon (L _ con_like_id) con_expr rbinds) = do
+dsExpr (RecordCon _ con_expr rbinds labels) = do
con_expr' <- dsExpr con_expr
let
(arg_tys, _) = tcSplitFunTys (exprType con_expr')
@@ -507,8 +507,6 @@ dsExpr (RecordCon (L _ con_like_id) con_expr rbinds) = do
[] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))
unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty
- labels = conLikeFieldLabels (idConLike con_like_id)
- -- The data_con_id is guaranteed to be the wrapper id of the constructor
con_args <- if null labels
then mapM unlabelled_bottom arg_tys
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 90dcea427e..2ad38c0e36 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1142,7 +1142,7 @@ repE e@(ExplicitTuple es boxed)
| otherwise = do { xs <- repLEs [e | L _ (Present e) <- es]
; repUnboxedTup xs }
-repE (RecordCon c _ flds)
+repE (RecordCon c _ flds _)
= do { x <- lookupLOcc c;
fs <- repFields flds;
repRecCon x fs }
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index deabf37d5b..28b699d3fd 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -711,7 +711,9 @@ cvtl e = wrapL (cvt e)
; return $ ExprWithTySig e' t' PlaceHolder }
cvt (RecConE c flds) = do { c' <- cNameL c
; flds' <- mapM (cvtFld mkFieldOcc) flds
- ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)}
+ ; return $ RecordCon c' noPostTcExpr
+ (HsRecFields flds' Nothing)
+ PlaceHolder }
cvt (RecUpdE e flds) = do { e' <- cvtl e
; flds'<- mapM (cvtFld mkAmbiguousFieldOcc) flds
; return $ RecordUpd e'
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index 84264b448f..5ee17cff9b 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -36,6 +36,7 @@ import StaticFlags( opt_PprStyle_Debug )
import Outputable
import FastString
import Type
+import FieldLabel
-- libraries:
import Data.Data hiding (Fixity)
@@ -284,6 +285,7 @@ data HsExpr id
-- it's the dataConWrapId of the constructor
PostTcExpr -- Data con Id applied to type args
(HsRecordBinds id)
+ (PostTc id [FieldLabel])
-- | Record update
--
@@ -727,7 +729,7 @@ ppr_expr (ExplicitList _ _ exprs)
ppr_expr (ExplicitPArr _ exprs)
= paBrackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
-ppr_expr (RecordCon con_id _ rbinds)
+ppr_expr (RecordCon con_id _ rbinds _)
= hang (ppr con_id) 2 (ppr rbinds)
ppr_expr (RecordUpd aexp rbinds _ _ _ _)
diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs
index ed44d2c73f..b37cd357d2 100644
--- a/compiler/hsSyn/PlaceHolder.hs
+++ b/compiler/hsSyn/PlaceHolder.hs
@@ -16,6 +16,7 @@ import Var
import Coercion
import {-# SOURCE #-} ConLike (ConLike)
import TcEvidence (HsWrapper)
+import FieldLabel
import Data.Data hiding ( Fixity )
import BasicTypes (Fixity)
@@ -111,4 +112,5 @@ type DataId id =
, Data (PostTc id [Type])
, Data (PostTc id [ConLike])
, Data (PostTc id HsWrapper)
+ , Data (PostTc id [FieldLabel])
)
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index af88e909b0..2d2b43b480 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -847,7 +847,7 @@ checkAPat msg loc e0 = do
return (TuplePat ps b [])
| otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
- RecordCon c _ (HsRecFields fs dd)
+ RecordCon c _ (HsRecFields fs dd) _
-> do fs <- mapM (checkPatField msg) fs
return (ConPatIn c (RecCon (HsRecFields fs dd)))
HsSpliceE s | not (isTypedSplice s)
@@ -1188,7 +1188,7 @@ mkRecConstrOrUpdate
mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd)
| isRdrDataCon c
- = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
+ = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd) PlaceHolder)
mkRecConstrOrUpdate exp@(L l _) _ (fs,dd)
| dd = parseErrorSDoc l (text "You cannot use `..' in a record update")
| otherwise = return (RecordUpd exp (map (fmap mk_rec_upd_field) fs)
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index e633f523c8..81ed15731e 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -251,11 +251,11 @@ rnExpr (ExplicitTuple tup_args boxity)
rnTupArg (L l (Missing _)) = return (L l (Missing placeHolderType)
, emptyFVs)
-rnExpr (RecordCon con_id _ rbinds)
+rnExpr (RecordCon con_id _ rbinds _)
= do { conname <- lookupLocatedOccRn con_id
; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
- ; return (RecordCon conname noPostTcExpr rbinds',
- fvRbinds `addOneFV` unLoc conname) }
+ ; return (RecordCon conname noPostTcExpr rbinds' PlaceHolder ,
+ fvRbinds `addOneFV` unLoc conname ) }
rnExpr (RecordUpd expr rbinds _ _ _ _)
= do { (expr', fvExpr) <- rnLExpr expr
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 5295ed967f..caf732ba7f 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -539,7 +539,7 @@ to support expressions like this:
************************************************************************
-}
-tcExpr (RecordCon (L loc con_name) _ rbinds) res_ty
+tcExpr (RecordCon (L loc con_name) _ rbinds _) res_ty
= do { con_like <- tcLookupConLike con_name
-- Check for missing fields
@@ -548,13 +548,14 @@ tcExpr (RecordCon (L loc con_name) _ rbinds) res_ty
; (con_expr, con_tau) <- tcInferId con_name
; let arity = conLikeArity con_like
(arg_tys, actual_res_ty) = tcSplitFunTysN con_tau arity
+ labels = conLikeFieldLabels con_like
; case conLikeWrapId_maybe con_like of
Nothing -> nonBidirectionalErr (conLikeName con_like)
Just con_id -> do {
co_res <- unifyType actual_res_ty res_ty
; rbinds' <- tcRecordBinds con_like arg_tys rbinds
; return $ mkHsWrapCo co_res $
- RecordCon (L loc con_id) con_expr rbinds' } }
+ RecordCon (L loc con_id) con_expr rbinds' labels } }
{-
Note [Type of a record update]
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index ddf9c4ff36..7dd9559089 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -704,10 +704,10 @@ zonkExpr env (ExplicitPArr ty exprs)
new_exprs <- zonkLExprs env exprs
return (ExplicitPArr new_ty new_exprs)
-zonkExpr env (RecordCon data_con con_expr rbinds)
+zonkExpr env (RecordCon data_con con_expr rbinds labels)
= do { new_con_expr <- zonkExpr env con_expr
; new_rbinds <- zonkRecFields env rbinds
- ; return (RecordCon data_con new_con_expr new_rbinds) }
+ ; return (RecordCon data_con new_con_expr new_rbinds labels) }
zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys req_wrap)
= do { new_expr <- zonkLExpr env expr
diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
index 777aae612a..aec7ac83b0 100644
--- a/compiler/typecheck/TcPatSyn.hs
+++ b/compiler/typecheck/TcPatSyn.hs
@@ -219,7 +219,7 @@ tc_patsyn_finish lname dir is_infix lpat'
theta = prov_theta ++ req_theta
arg_tys = map (varType . fst) wrapped_args
- ; (patSyn, matcher_bind) <- fixM $ \ ~(patSyn,_) -> do {
+ ;
traceTc "tc_patsyn_finish {" $
ppr (unLoc lname) $$ ppr (unLoc lpat') $$
@@ -238,7 +238,7 @@ tc_patsyn_finish lname dir is_infix lpat'
-- Make the 'builder'
; builder_id <- mkPatSynBuilderId dir lname qtvs theta
- arg_tys pat_ty patSyn
+ arg_tys pat_ty
-- TODO: Make this have the proper information
; let mkFieldLabel name = FieldLabel (occNameFS (nameOccName name)) False name
@@ -246,14 +246,13 @@ tc_patsyn_finish lname dir is_infix lpat'
-- Make the PatSyn itself
- ; let patSyn' = mkPatSyn (unLoc lname) is_infix
+ ; let patSyn = mkPatSyn (unLoc lname) is_infix
(univ_tvs, req_theta)
(ex_tvs, prov_theta)
arg_tys
pat_ty
matcher_id builder_id
field_labels'
- ; return (patSyn', matcher_bind) }
-- Selectors
; let (sigs, selector_binds) =
@@ -388,9 +387,9 @@ isUnidirectional ExplicitBidirectional{} = False
-}
mkPatSynBuilderId :: HsPatSynDir a -> Located Name
- -> [TyVar] -> ThetaType -> [Type] -> Type -> PatSyn
+ -> [TyVar] -> ThetaType -> [Type] -> Type
-> TcM (Maybe (Id, Bool))
-mkPatSynBuilderId dir (L _ name) qtvs theta arg_tys pat_ty pat_syn
+mkPatSynBuilderId dir (L _ name) qtvs theta arg_tys pat_ty
| isUnidirectional dir
= return Nothing
| otherwise
@@ -398,8 +397,7 @@ mkPatSynBuilderId dir (L _ name) qtvs theta arg_tys pat_ty pat_syn
; let builder_sigma = mkSigmaTy qtvs theta (mkFunTys builder_arg_tys pat_ty)
builder_id =
-- See Note [Exported LocalIds] in Id
- mkExportedLocalId (PatSynBuilderId pat_syn)
- builder_name builder_sigma
+ mkExportedLocalId VanillaId builder_name builder_sigma
; return (Just (builder_id, need_dummy_arg)) }
where
builder_arg_tys | need_dummy_arg = [voidPrimTy]
View Lorry Controller Status