Remove PatSynBuilderId
authorMatthew Pickering <matthewtpickering@gmail.com>
Sat, 7 Nov 2015 23:46:03 +0000 (23:46 +0000)
committerMatthew Pickering <matthewtpickering@gmail.com>
Sat, 7 Nov 2015 23:46:41 +0000 (23:46 +0000)
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

13 files changed:
compiler/basicTypes/Id.hs
compiler/basicTypes/IdInfo.hs
compiler/deSugar/Coverage.hs
compiler/deSugar/DsExpr.hs
compiler/deSugar/DsMeta.hs
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsExpr.hs
compiler/hsSyn/PlaceHolder.hs
compiler/parser/RdrHsSyn.hs
compiler/rename/RnExpr.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcPatSyn.hs

index e22a77c..b49a816 100644 (file)
@@ -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.
index ea1eb19..94d3441 100644 (file)
@@ -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")
 
 {-
 ************************************************************************
index dfe3807..0678ace 100644 (file)
@@ -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`
index 2f7ebd8..075a647 100644 (file)
@@ -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
index 90dcea4..2ad38c0 100644 (file)
@@ -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 }
index deabf37..28b699d 100644 (file)
@@ -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'
index 84264b4..5ee17cf 100644 (file)
@@ -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 _ _ _ _)
index ed44d2c..b37cd35 100644 (file)
@@ -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])
   )
index af88e90..2d2b43b 100644 (file)
@@ -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)
index e633f52..81ed157 100644 (file)
@@ -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
index 5295ed9..caf732b 100644 (file)
@@ -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]
index ddf9c4f..7dd9559 100644 (file)
@@ -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
index 777aae6..aec7ac8 100644 (file)
@@ -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]