-- The representation tycon looks like this:
-- data :R7T b c where
-- TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1
-
- orig_res_ty
- | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tycon
- , let fam_subst = zipTopTvSubst (tyConTyVars tycon) res_tys
- = mkTyConApp fam_tc (substTys fam_subst fam_tys)
- | otherwise
- = mkTyConApp tycon res_tys
- where
- res_tys = substTyVars (mkTopTvSubst eq_spec) univ_tvs
- -- In the example above,
- -- univ_tvs = [ b1, c1 ]
- -- res_tys = [ b1, b1 ]
+ orig_res_ty = mkFamilyTyConApp tycon (substTyVars (mkTopTvSubst eq_spec) univ_tvs)
-- Representation arguments and demands
-- To do: eliminate duplication with MkId
dataConUserType :: DataCon -> Type
-- The user-declared type of the data constructor
-- in the nice-to-read form
--- T :: forall a. a -> T [a]
+-- T :: forall a b. a -> b -> T [a]
-- rather than
--- T :: forall b. forall a. (a=[b]) => a -> T b
+-- T :: forall a c. forall b. (c=[a]) => a -> b -> T c
-- NB: If the constructor is part of a data instance, the result type
-- mentions the family tycon, not the internal one.
dataConUserType (MkData { dcUnivTyVars = univ_tvs,
-- and for constructors visible
-> Just (tycon, ty_args, data_con, dataConInstArgTys data_con ty_args)
where
- data_con = head (tyConDataCons tycon)
+ data_con = ASSERT( not (null (tyConDataCons tycon)) )
+ head (tyConDataCons tycon)
other -> Nothing
splitProductType str ty
con1 = head data_cons_w_field
(univ_tvs, _, eq_spec, _, _, data_ty) = dataConFullSig con1
+ -- For a data type family, the data_ty (and hence selector_ty) mentions
+ -- only the family TyCon, not the instance TyCon
data_tv_set = tyVarsOfType data_ty
data_tvs = varSetElems data_tv_set
field_ty = dataConFieldType con1 field_label
liftM2 ExplicitTuple
(mapM (addTickLHsExpr) es)
(return box)
-addTickHsExpr (RecordCon id ty rec_binds) =
+addTickHsExpr (RecordCon id ty rec_binds) =
liftM3 RecordCon
(return id)
(return ty)
(addTickHsRecordBinds rec_binds)
-addTickHsExpr (RecordUpd e rec_binds ty1 ty2) =
- liftM4 RecordUpd
+addTickHsExpr (RecordUpd e rec_binds cons tys1 tys2) =
+ liftM5 RecordUpd
(addTickLHsExpr e)
(addTickHsRecordBinds rec_binds)
- (return ty1)
- (return ty2)
+ (return cons) (return tys1) (return tys2)
+
addTickHsExpr (ExprWithTySig {}) = error "addTickHsExpr: ExprWithTySig"
addTickHsExpr (ExprWithTySigOut e ty) =
liftM2 ExprWithTySigOut
import Id
import PrelInfo
import DataCon
-import TyCon
import TysWiredIn
import BasicTypes
import PrelNames
dictionaries.
\begin{code}
-dsExpr (RecordUpd record_expr (HsRecordBinds []) record_in_ty record_out_ty)
+dsExpr (RecordUpd record_expr (HsRecordBinds []) _ _ _)
= dsLExpr record_expr
-dsExpr expr@(RecordUpd record_expr (HsRecordBinds rbinds) record_in_ty record_out_ty)
- = dsLExpr record_expr `thenDs` \ record_expr' ->
-
- -- Desugar the rbinds, and generate let-bindings if
- -- necessary so that we don't lose sharing
-
- let
- in_inst_tys = tcTyConAppArgs record_in_ty -- Newtype opaque
- out_inst_tys = tcTyConAppArgs record_out_ty -- Newtype opaque
- in_out_ty = mkFunTy record_in_ty record_out_ty
-
- mk_val_arg field old_arg_id
- = case [rhs | (L _ sel_id, rhs) <- rbinds, field == idName sel_id] of
- (rhs:rest) -> ASSERT(null rest) rhs
- [] -> nlHsVar old_arg_id
-
- mk_alt con
- = ASSERT( isVanillaDataCon con )
- newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys) `thenDs` \ arg_ids ->
- -- This call to dataConInstOrigArgTys won't work for existentials
- -- but existentials don't have record types anyway
- let
- val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
- (dataConFieldLabels con) arg_ids
- rhs = foldl (\a b -> nlHsApp a b)
- (nlHsTyApp (dataConWrapId con) out_inst_tys)
- val_args
- in
- returnDs (mkSimpleMatch [mkPrefixConPat con (map nlVarPat arg_ids) record_in_ty] rhs)
- in
- -- Record stuff doesn't work for existentials
+dsExpr expr@(RecordUpd record_expr (HsRecordBinds rbinds) cons_to_upd in_inst_tys out_inst_tys)
+ = -- Record stuff doesn't work for existentials
-- The type checker checks for this, but we need
-- worry only about the constructors that are to be updated
- ASSERT2( all isVanillaDataCon cons_to_upd, ppr expr )
+ ASSERT2( notNull cons_to_upd && all isVanillaDataCon cons_to_upd, ppr expr )
+
+ do { record_expr' <- dsLExpr record_expr
+ ; let -- Awkwardly, for families, the match goes
+ -- from instance type to family type
+ tycon = dataConTyCon (head cons_to_upd)
+ in_ty = mkTyConApp tycon in_inst_tys
+ in_out_ty = mkFunTy in_ty
+ (mkFamilyTyConApp tycon out_inst_tys)
+
+ mk_val_arg field old_arg_id
+ = case [rhs | (L _ sel_id, rhs) <- rbinds, field == idName sel_id] of
+ (rhs:rest) -> ASSERT(null rest) rhs
+ [] -> nlHsVar old_arg_id
+
+ mk_alt con
+ = ASSERT( isVanillaDataCon con )
+ do { arg_ids <- newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys)
+ -- This call to dataConInstOrigArgTys won't work for existentials
+ -- but existentials don't have record types anyway
+ ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
+ (dataConFieldLabels con) arg_ids
+ rhs = foldl (\a b -> nlHsApp a b)
+ (nlHsTyApp (dataConWrapId con) out_inst_tys)
+ val_args
+ pat = mkPrefixConPat con (map nlVarPat arg_ids) in_ty
+
+ ; return (mkSimpleMatch [pat] rhs) }
-- It's important to generate the match with matchWrapper,
-- and the right hand sides with applications of the wrapper Id
-- so that everything works when we are doing fancy unboxing on the
-- constructor aguments.
- mappM mk_alt cons_to_upd `thenDs` \ alts ->
- matchWrapper RecUpd (MatchGroup alts in_out_ty) `thenDs` \ ([discrim_var], matching_code) ->
+ ; alts <- mapM mk_alt cons_to_upd
+ ; ([discrim_var], matching_code) <- matchWrapper RecUpd (MatchGroup alts in_out_ty)
- returnDs (bindNonRec discrim_var record_expr' matching_code)
-
- where
- updated_fields :: [FieldLabel]
- updated_fields = [ idName sel_id | (L _ sel_id,_) <- rbinds]
-
- -- Get the type constructor from the record_in_ty
- -- so that we are sure it'll have all its DataCons
- -- (In GHCI, it's possible that some TyCons may not have all
- -- their constructors, in a module-loop situation.)
- tycon = tcTyConAppTyCon record_in_ty
- data_cons = tyConDataCons tycon
- cons_to_upd = filter has_all_fields data_cons
-
- has_all_fields :: DataCon -> Bool
- has_all_fields con_id
- = all (`elem` con_fields) updated_fields
- where
- con_fields = dataConFieldLabels con_id
+ ; return (bindNonRec discrim_var record_expr' matching_code) }
\end{code}
Here is where we desugar the Template Haskell brackets and escapes
= do { x <- lookupLOcc c;
fs <- repFields flds;
repRecCon x fs }
-repE (RecordUpd e (HsRecordBinds flds) _ _)
+repE (RecordUpd e (HsRecordBinds flds) _ _ _)
= do { x <- repLE e;
fs <- repFields flds;
repRecUpd x fs }
; return $ RecordCon c' noPostTcExpr (HsRecordBinds flds') }
cvt (RecUpdE e flds) = do { e' <- cvtl e
; flds' <- mapM cvtFld flds
- ; return $ RecordUpd e' (HsRecordBinds flds') placeHolderType placeHolderType }
+ ; return $ RecordUpd e' (HsRecordBinds flds') [] [] [] }
cvtFld (v,e) = do { v' <- vNameL v; e' <- cvtl e; return (v',e') }
import Var
import Name
import BasicTypes
+import DataCon
import SrcLoc
import Outputable
import FastString
-- Record update
| RecordUpd (LHsExpr id)
(HsRecordBinds id)
- PostTcType -- Type of *input* record
- PostTcType -- Type of *result* record (may differ from
- -- type of input record)
+ [DataCon] -- Filled in by the type checker to the *non-empty*
+ -- list of DataCons that have all the upd'd fields
+ [PostTcType] -- Argument types of *input* record type
+ [PostTcType] -- and *output* record type
+ -- For a type family, the arg types are of the *instance* tycon, not the family tycon
| ExprWithTySig -- e :: type
(LHsExpr id)
ppr_expr (RecordCon con_id con_expr rbinds)
= pp_rbinds (ppr con_id) rbinds
-ppr_expr (RecordUpd aexp rbinds _ _)
+ppr_expr (RecordUpd aexp rbinds _ _ _)
= pp_rbinds (pprParendExpr aexp) rbinds
ppr_expr (ExprWithTySig expr sig)
mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
= return (RecordCon (L l c) noPostTcExpr fs)
mkRecConstrOrUpdate exp loc fs@(HsRecordBinds (_:_))
- = return (RecordUpd exp fs placeHolderType placeHolderType)
+ = return (RecordUpd exp fs [] [] [])
mkRecConstrOrUpdate _ loc (HsRecordBinds [])
= parseError loc "Empty record update"
returnM (RecordCon conname noPostTcExpr (HsRecordBinds rbinds'),
fvRbinds `addOneFV` unLoc conname)
-rnExpr (RecordUpd expr (HsRecordBinds rbinds) _ _)
+rnExpr (RecordUpd expr (HsRecordBinds rbinds) _ _ _)
= rnLExpr expr `thenM` \ (expr', fvExpr) ->
rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) ->
- returnM (RecordUpd expr' (HsRecordBinds rbinds') placeHolderType placeHolderType,
+ returnM (RecordUpd expr' (HsRecordBinds rbinds') [] [] [],
fvExpr `plusFV` fvRbinds)
rnExpr (ExprWithTySig expr pty)
-- don't know how to do the update otherwise.
-tcExpr expr@(RecordUpd record_expr hrbinds@(HsRecordBinds rbinds) _ _) res_ty
+tcExpr expr@(RecordUpd record_expr hrbinds@(HsRecordBinds rbinds) _ _ _) res_ty
= -- STEP 0
-- Check that the field names are really field names
ASSERT( notNull rbinds )
upd_field_lbls = recBindFields hrbinds
sel_id : _ = sel_ids
(tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if
- data_cons = tyConDataCons tycon -- it's not a field label
+ data_cons = tyConDataCons tycon -- it's not a field label
+ -- NB: for a data type family, the tycon is the instance tycon
+
relevant_cons = filter is_relevant data_cons
is_relevant con = all (`elem` dataConFieldLabels con) upd_field_lbls
in
let
-- A constructor is only relevant to this process if
-- it contains *all* the fields that are being updated
- con1 = head relevant_cons -- A representative constructor
- con1_tyvars = dataConUnivTyVars con1
- con1_flds = dataConFieldLabels con1
- con1_arg_tys = dataConOrigArgTys con1
- common_tyvars = exactTyVarsOfTypes [ty | (fld,ty) <- con1_flds `zip` con1_arg_tys
- , not (fld `elem` upd_field_lbls) ]
+ con1 = ASSERT( not (null relevant_cons) ) head relevant_cons -- A representative constructor
+ (con1_tyvars, theta, con1_arg_tys, con1_res_ty) = dataConSig con1
+ con1_flds = dataConFieldLabels con1
+ common_tyvars = exactTyVarsOfTypes [ty | (fld,ty) <- con1_flds `zip` con1_arg_tys
+ , not (fld `elem` upd_field_lbls) ]
is_common_tv tv = tv `elemVarSet` common_tyvars
| is_common_tv tv = returnM result_inst_ty -- Same as result type
| otherwise = newFlexiTyVarTy (tyVarKind tv) -- Fresh type, of correct kind
in
- tcInstTyVars con1_tyvars `thenM` \ (_, result_inst_tys, inst_env) ->
- zipWithM mk_inst_ty con1_tyvars result_inst_tys `thenM` \ inst_tys ->
+ ASSERT( null theta ) -- Vanilla datacon
+ tcInstTyVars con1_tyvars `thenM` \ (_, result_inst_tys, result_inst_env) ->
+ zipWithM mk_inst_ty con1_tyvars result_inst_tys `thenM` \ scrut_inst_tys ->
- -- STEP 3
- -- Typecheck the update bindings.
- -- (Do this after checking for bad fields in case there's a field that
- -- doesn't match the constructor.)
+ -- STEP 3: Typecheck the update bindings.
+ -- Do this after checking for bad fields in case
+ -- there's a field that doesn't match the constructor.
let
- result_record_ty = mkTyConApp tycon result_inst_tys
- con1_arg_tys' = map (substTy inst_env) con1_arg_tys
+ result_ty = substTy result_inst_env con1_res_ty
+ con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys
in
- tcSubExp result_record_ty res_ty `thenM` \ co_fn ->
+ tcSubExp result_ty res_ty `thenM` \ co_fn ->
tcRecordBinds con1 con1_arg_tys' hrbinds `thenM` \ rbinds' ->
- -- STEP 5
- -- Typecheck the expression to be updated
+ -- STEP 5: Typecheck the expression to be updated
let
- record_ty = ASSERT( length inst_tys == tyConArity tycon )
- mkTyConApp tycon inst_tys
+ scrut_inst_env = zipTopTvSubst con1_tyvars scrut_inst_tys
+ scrut_ty = substTy scrut_inst_env con1_res_ty
-- This is one place where the isVanilla check is important
- -- So that inst_tys matches the tycon
+ -- So that inst_tys matches the con1_tyvars
in
- tcMonoExpr record_expr record_ty `thenM` \ record_expr' ->
+ tcMonoExpr record_expr scrut_ty `thenM` \ record_expr' ->
- -- STEP 6
- -- Figure out the LIE we need. We have to generate some
- -- dictionaries for the data type context, since we are going to
- -- do pattern matching over the data cons.
+ -- STEP 6: Figure out the LIE we need.
+ -- We have to generate some dictionaries for the data type context,
+ -- since we are going to do pattern matching over the data cons.
--
- -- What dictionaries do we need? The tyConStupidTheta tells us.
+ -- What dictionaries do we need? The dataConStupidTheta tells us.
let
- theta' = substTheta inst_env (tyConStupidTheta tycon)
+ theta' = substTheta scrut_inst_env (dataConStupidTheta con1)
in
instStupidTheta RecordUpdOrigin theta' `thenM_`
+ -- Step 7: make a cast for the scrutinee, in the case that it's from a type family
+ let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon
+ = WpCo $ mkTyConApp co_con scrut_inst_tys
+ | otherwise
+ = idHsWrapper
+ scrut_ty = mkTyConApp tycon scrut_inst_tys -- Type of pattern, the result of the cast
+ in
-- Phew!
- returnM (mkHsWrap co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty))
+ returnM (mkHsWrap co_fn (RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
+ relevant_cons scrut_inst_tys result_inst_tys))
\end{code}
; qtys' <- mapM refineBox qtys -- Exploit new info
; (qtys'', args') <- go (n+1) qtys' args arg_tys
; return (qtys'', arg':args') }
+ go n qtys args arg_tys = panic "tcArgs"
tcArg :: LHsExpr Name -- The function
-> Int -- and arg number (for error messages)
= hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
nonVanillaUpd tycon
- = vcat [ptext SLIT("Record update for the non-Haskell-98 data type") <+> quotes (ppr tycon)
+ = vcat [ptext SLIT("Record update for the non-Haskell-98 data type")
+ <+> quotes (pprSourceTyCon tycon)
<+> ptext SLIT("is not (yet) supported"),
ptext SLIT("Use pattern-matching instead")]
badFieldsUpd rbinds
= ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:")
<+> pprWithCommas ppr fields
-callCtxt fun args
- = ptext SLIT("In the call") <+> parens (ppr (foldl mkHsApp fun args))
+-- callCtxt fun args = ptext SLIT("In the call") <+> parens (ppr (foldl mkHsApp fun args))
#ifdef GHCI
polySpliceErr :: Id -> SDoc
zonkRbinds env rbinds `thenM` \ new_rbinds ->
returnM (RecordCon data_con new_con_expr new_rbinds)
-zonkExpr env (RecordUpd expr rbinds in_ty out_ty)
- = zonkLExpr env expr `thenM` \ new_expr ->
- zonkTcTypeToType env in_ty `thenM` \ new_in_ty ->
- zonkTcTypeToType env out_ty `thenM` \ new_out_ty ->
- zonkRbinds env rbinds `thenM` \ new_rbinds ->
- returnM (RecordUpd new_expr new_rbinds new_in_ty new_out_ty)
+zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys)
+ = zonkLExpr env expr `thenM` \ new_expr ->
+ mapM (zonkTcTypeToType env) in_tys `thenM` \ new_in_tys ->
+ mapM (zonkTcTypeToType env) out_tys `thenM` \ new_out_tys ->
+ zonkRbinds env rbinds `thenM` \ new_rbinds ->
+ returnM (RecordUpd new_expr new_rbinds cons new_in_tys new_out_tys)
zonkExpr env (ExprWithTySigOut e ty)
= do { e' <- zonkLExpr env e
applyTy, applyTys, isForAllTy, dropForAlls,
-- Source types
- predTypeRep, mkPredTy, mkPredTys, pprSourceTyCon,
+ predTypeRep, mkPredTy, mkPredTys, pprSourceTyCon, mkFamilyTyConApp,
-- Newtypes
splitRecNewType_maybe, newTyConInstRhs,
-- look through that too if necessary
predTypeRep (EqPred ty1 ty2) = pprPanic "predTypeRep" (ppr (EqPred ty1 ty2))
+mkFamilyTyConApp :: TyCon -> [Type] -> Type
+-- Given a family instance TyCon and its arg types, return the
+-- corresponding family type. E.g.
+-- data family T a
+-- data instance T (Maybe b) = MkT b -- Instance tycon :RTL
+-- Then
+-- mkFamilyTyConApp :RTL Int = T (Maybe Int)
+mkFamilyTyConApp tc tys
+ | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc
+ , let fam_subst = zipTopTvSubst (tyConTyVars tc) tys
+ = mkTyConApp fam_tc (substTys fam_subst fam_tys)
+ | otherwise
+ = mkTyConApp tc tys
+
-- Pretty prints a tycon, using the family instance in case of a
-- representation tycon. For example
-- e.g. data T [a] = ...
-- In that case we want to print `T [a]', where T is the family TyCon
pprSourceTyCon tycon
- | Just (repTyCon, tys) <- tyConFamInst_maybe tycon
- = ppr $ repTyCon `TyConApp` tys -- can't be FunTyCon
+ | Just (fam_tc, tys) <- tyConFamInst_maybe tycon
+ = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon
| otherwise
= ppr tycon
\end{code}
Just (substTyWith tvs tys rep_ty)
splitRecNewType_maybe other = Nothing
-
-
-
\end{code}
projects / ghc-hetmet.git / commitdiff