Commit ff8e1d01 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Make records work properly with type families

This fixes Trac #1204.  There's quite a delicate interaction of
GADTs, type families, records, and in particular record updates.

Test is indexed-types/should_compile/Records.hs
parent 86bec429
......@@ -492,18 +492,7 @@ mkDataCon name declared_infix
-- 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
......@@ -645,9 +634,9 @@ dataConStupidTheta dc = dcStupidTheta dc
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,
......@@ -756,7 +745,8 @@ splitProductType_maybe ty
-- 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
......
......@@ -493,6 +493,8 @@ mkRecordSelId tycon field_label
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
......
......@@ -294,17 +294,17 @@ addTickHsExpr (ExplicitTuple es box) =
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
......
......@@ -40,7 +40,6 @@ import CostCentre
import Id
import PrelInfo
import DataCon
import TyCon
import TysWiredIn
import BasicTypes
import PrelNames
......@@ -456,70 +455,50 @@ might do some argument-evaluation first; and may have to throw away some
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
......
......@@ -531,7 +531,7 @@ repE (RecordCon c _ (HsRecordBinds flds))
= 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 }
......
......@@ -367,7 +367,7 @@ cvtl e = wrapL (cvt e)
; 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') }
......
......@@ -22,6 +22,7 @@ import HsBinds
import Var
import Name
import BasicTypes
import DataCon
import SrcLoc
import Outputable
import FastString
......@@ -158,9 +159,11 @@ data HsExpr id
-- 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)
......@@ -380,7 +383,7 @@ ppr_expr (ExplicitTuple exprs boxity)
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)
......
......@@ -872,7 +872,7 @@ mkRecConstrOrUpdate
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"
......
......@@ -229,10 +229,10 @@ rnExpr (RecordCon con_id _ (HsRecordBinds rbinds))
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)
......
......@@ -382,7 +382,7 @@ tcExpr expr@(RecordCon (L loc con_name) _ rbinds) res_ty
-- 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 )
......@@ -407,7 +407,9 @@ tcExpr expr@(RecordUpd record_expr hrbinds@(HsRecordBinds rbinds) _ _) res_ty
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
......@@ -432,12 +434,11 @@ tcExpr expr@(RecordUpd record_expr hrbinds@(HsRecordBinds rbinds) _ _) res_ty
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
......@@ -445,43 +446,49 @@ tcExpr expr@(RecordUpd record_expr hrbinds@(HsRecordBinds rbinds) _ _) res_ty
| 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}
......@@ -856,6 +863,7 @@ tcArgs fun args qtvs qtys arg_tys
; 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)
......@@ -1131,7 +1139,8 @@ predCtxt expr
= 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
......@@ -1162,8 +1171,7 @@ missingFields con fields
= 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
......
......@@ -463,12 +463,12 @@ zonkExpr env (RecordCon data_con con_expr rbinds)
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
......
......@@ -54,7 +54,7 @@ module Type (
applyTy, applyTys, isForAllTy, dropForAlls,
-- Source types
predTypeRep, mkPredTy, mkPredTys, pprSourceTyCon,
predTypeRep, mkPredTy, mkPredTys, pprSourceTyCon, mkFamilyTyConApp,
-- Newtypes
splitRecNewType_maybe, newTyConInstRhs,
......@@ -603,13 +603,27 @@ predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
-- 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}
......@@ -637,9 +651,6 @@ splitRecNewType_maybe (TyConApp tc tys)
Just (substTyWith tvs tys rep_ty)
splitRecNewType_maybe other = Nothing
\end{code}
......
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