Make records work properly with type families
authorsimonpj@microsoft.com <unknown>
Wed, 2 May 2007 16:34:57 +0000 (16:34 +0000)
committersimonpj@microsoft.com <unknown>
Wed, 2 May 2007 16:34:57 +0000 (16:34 +0000)
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

12 files changed:
compiler/basicTypes/DataCon.lhs
compiler/basicTypes/MkId.lhs
compiler/deSugar/Coverage.lhs
compiler/deSugar/DsExpr.lhs
compiler/deSugar/DsMeta.hs
compiler/hsSyn/Convert.lhs
compiler/hsSyn/HsExpr.lhs
compiler/parser/RdrHsSyn.lhs
compiler/rename/RnExpr.lhs
compiler/typecheck/TcExpr.lhs
compiler/typecheck/TcHsSyn.lhs
compiler/types/Type.lhs

index a3504a6..a83d5f8 100644 (file)
@@ -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
index 42515eb..c4618ca 100644 (file)
@@ -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
index 530e7d2..e56f231 100644 (file)
@@ -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
index 4163559..dd433ec 100644 (file)
@@ -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
index fa7fafe..11a5323 100644 (file)
@@ -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 }
index 4ed7364..241eb44 100644 (file)
@@ -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') }
 
index 7759885..e56eeac 100644 (file)
@@ -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)
index 7a6a0e9..8eea797 100644 (file)
@@ -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"
 
index e78e942..e5ce559 100644 (file)
@@ -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)
index 4151e0d..14a1d6d 100644 (file)
@@ -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
index 3736184..9411a3a 100644 (file)
@@ -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
index 25c5968..37f915b 100644 (file)
@@ -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}