Commit 22080113 authored by Matthew Pickering's avatar Matthew Pickering

Remove PatSynBuilderId

Summary:
It was only used to pass field labels between the typechecker and
desugarer. Instead we add an extra field the RecordCon to carry this
information.

Reviewers: austin, goldfire, bgamari

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1443

GHC Trac Issues: #11057
parent be885857
......@@ -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.
......
......@@ -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")
{-
************************************************************************
......
......@@ -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`
......
......@@ -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
......
......@@ -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 }
......
......@@ -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'
......
......@@ -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 _ _ _ _)
......
......@@ -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])
)
......@@ -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)
......
......@@ -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
......
......@@ -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]
......
......@@ -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
......
......@@ -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]
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment