Don't generate a full TyCon for the AT defaultsat-defaults

8 files changed, 98 insertions, 67 deletions

diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 55fcec0658..28b60c41cf 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -103,9 +103,13 @@ data IfaceClassOp = IfaceClassOp OccName DefMethSpec IfaceType
         -- Just False => ordinary polymorphic default method
         -- Just True  => generic default method
 
-data IfaceAT = IfaceAT IfaceDecl (Maybe [IfaceDecl])
+data IfaceAT = IfaceAT IfaceDecl (Maybe [([IfaceTvBndr], [IfaceType], IfaceType)])
         -- Nothing => no default associated type instance
-        -- Just ds => default associated type instance from these TyCon decls
+        -- Just ds => default associated type instance from these templates
+        -- Each template is a triple of:
+        --   1. TyVars of the RHS and family arguments (including the class TVs)
+        --   3. The instantiated family arguments
+        --   2. The RHS of the synonym
 
 data IfaceConDecls
   = IfAbstractTyCon Bool        -- c.f TyCon.AbstractTyCon
@@ -388,7 +392,7 @@ ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ,
     --    no wrapper (class dictionaries never have a wrapper)
     [dc_occ, dcww_occ] ++
     -- associated types
-    [n | IfaceAT at mb_defs <- ats, n <- ifName at : maybe [] (map ifName) mb_defs ] ++
+    [ifName at | IfaceAT at _ <- ats ] ++
     -- superclass selectors
     [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]] ++
     -- operation selectors
@@ -733,7 +737,11 @@ freeNamesIfContext = fnList freeNamesIfPredType
 freeNamesIfAT :: IfaceAT -> NameSet
 freeNamesIfAT (IfaceAT decl mb_defs)
   = freeNamesIfDecl decl &&&
-    maybe emptyNameSet (fnList freeNamesIfDecl) mb_defs
+    maybe emptyNameSet (fnList fn_at_def) mb_defs
+  where
+    fn_at_def (tvs, pat_tys, ty) = freeNamesIfTvBndrs tvs &&&
+                                   fnList freeNamesIfType pat_tys &&&
+                                   freeNamesIfType ty
 
 freeNamesIfClsSig :: IfaceClassOp -> NameSet
 freeNamesIfClsSig (IfaceClassOp _n _dm ty) = freeNamesIfType ty
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index f43cbd48fc..a04ce174ad 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1339,9 +1339,13 @@ tyThingToIfaceDecl (AClass clas)
       = classExtraBigSig clas
     tycon = classTyCon clas
 
+    toIfaceAT :: ClassATItem -> IfaceAT
     toIfaceAT (tc, def_tcs)
       = IfaceAT (tyThingToIfaceDecl (ATyCon tc))
-                (fmap (map (tyThingToIfaceDecl . ATyCon)) def_tcs)
+                (fmap (map to_if_at_def) def_tcs)
+      where
+        to_if_at_def (tvs, pat_tys, ty)
+          = (toIfaceTvBndrs tvs, map toIfaceType pat_tys, toIfaceType ty)
 
     toIfaceClassOp (sel_id, def_meth)
 	= ASSERT(sel_tyvars == clas_tyvars)
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 8f2906868b..deeb649cef 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -494,14 +494,17 @@ tc_iface_decl _parent ignore_prags
 
    tc_at cls (IfaceAT tc_decl mb_def_decls)
      = do tc <- tc_iface_tc_decl (AssocFamilyTyCon cls) tc_decl
-          mb_def_tcs <- traverse (mapM (tc_iface_tc_decl NoParentTyCon)) mb_def_decls
+          mb_def_tcs <- traverse (mapM tc_iface_at_def) mb_def_decls
            -- Defaults are just like associated type instances: their real parent will
            -- be filled in later by mkFamInstParentInfo (called by buildSynTyCon)
           return (tc, mb_def_tcs)
 
    tc_iface_tc_decl parent decl = do
-        ATyCon tc <- tc_iface_decl parent ignore_prags decl
-        return tc
+      ATyCon tc <- tc_iface_decl parent ignore_prags decl
+      return tc
+
+   tc_iface_at_def (tvs, pat_tys, ty) =
+        bindIfaceTyVars_AT tvs $ \tvs' -> liftM2 ((,,) tvs') (mapM tcIfaceType pat_tys) (tcIfaceType ty)
 
    mk_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty]
 
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 78c3aa3003..d97ca84d90 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -36,7 +36,7 @@ import DataCon
 import Class
 import Var
 import VarEnv
-import VarSet     ( mkVarSet, unionVarSet, varSetElems )
+import VarSet     ( mkVarSet, varSetElems )
 import Pair
 import CoreUtils  ( mkPiTypes )
 import CoreUnfold ( mkDFunUnfolding )
@@ -468,20 +468,16 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
                  else case mb_defs of
                         Nothing   -> return (Just (tyConName fam_tc), [])
                         Just defs -> do
-                            defs' <- forM defs $ \def -> do
-                             case tyConFamInst_maybe def of
-                              Nothing -> pprPanic "tcLocalInstDecl1:not family instance TyCon" (ppr def)
-                              Just (parent_fam_tc, fam_inst_tys) -> ASSERT(parent_fam_tc == fam_tc) do
-                                let SynonymTyCon rhs = synTyConRhs def
-                                    iss = mkInScopeSet (tyVarsOfTypes fam_inst_tys `unionVarSet` tyVarsOfType rhs)
-                                    mini_env_subst = mkTvSubst iss mini_env
-                                    fam_inst_tys' = substTys mini_env_subst fam_inst_tys
-                                    rhs' = substTy mini_env_subst rhs
-                                rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) fam_inst_tys'
-                                buildSynTyCon rep_tc_name (varSetElems (tyVarsOfType rhs'))
-                                              (SynonymTyCon rhs')
-                                              (tyConKind def)
-                                              NoParentTyCon (Just (fam_tc, fam_inst_tys'))
+                            defs' <- forM defs $ \(tvs, pat_tys, rhs) -> do
+                              let mini_env_subst = mkTvSubst (mkInScopeSet (mkVarSet tvs)) mini_env
+                                  tvs' = varSetElems (tyVarsOfType rhs')
+                                  pat_tys' = substTys mini_env_subst pat_tys
+                                  rhs' = substTy mini_env_subst rhs
+                              rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys'
+                              buildSynTyCon rep_tc_name tvs'
+                                            (SynonymTyCon rhs')
+                                            (mkArrowKinds (map tyVarKind tvs') (typeKind rhs'))
+                                            NoParentTyCon (Just (fam_tc, pat_tys'))
                             return (Nothing, defs')
         
         ; let (omitted, idx_tycons1) = unzip missing_at_stuff
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 503195924e..e95ccecca3 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -719,7 +719,13 @@ checkBootDecl (AClass c1)  (AClass c2)
 
        eqAT (tc1, def_ats1) (tc2, def_ats2)
          = checkBootTyCon tc1 tc2 &&
-           def_ats1 == def_ats2
+           eqMaybeBy (eqListBy eqATDef) def_ats1 def_ats2
+
+       eqATDef (tvs1, ty_pats1, ty1) (tvs2, ty_pats2, ty2)
+         = eqListBy same_kind tvs1 tvs2 &&
+           eqListBy (eqTypeX env) ty_pats1 ty_pats2 &&
+           eqTypeX env ty1 ty2
+         where env = rnBndrs2 env0 tvs1 tvs2
 
        eqFD (as1,bs1) (as2,bs2) = 
          eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
@@ -734,7 +740,7 @@ checkBootDecl (AClass c1)  (AClass c2)
         ||   -- Above tests for an "abstract" class
         eqListBy (eqPredX env) sc_theta1 sc_theta2 &&
         eqListBy eqSig op_stuff1 op_stuff2 &&
-        eqListBy eqAT ats1 ats2)
+        eqListBy eqAT ats1 ats2) 
 
 checkBootDecl (ADataCon dc1) (ADataCon _)
   = pprPanic "checkBootDecl" (ppr dc1)
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 635584a193..e613715eb8 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -8,7 +8,7 @@ TcTyClsDecls: Typecheck type and class declarations
 \begin{code}
 module TcTyClsDecls (
 	tcTyAndClassDecls, kcDataDecl, tcConDecls, mkRecSelBinds,
-        tcTopFamInstDecl, tcAssocDecl, tcDefaultAssocDecl,
+        tcTopFamInstDecl, tcAssocDecl,
         checkValidTyCon, dataDeclChecks
     ) where
 
@@ -583,12 +583,7 @@ tcClassATs clas clas_tvs ats at_defs = do
         dat <- case lookupNameEnv at_defs_map (tyConName fam_tc) of
                  Nothing        -> return Nothing
                  Just def_decls -> do
-                   liftM Just $ mapM (\def_decl -> do
-                     -- NB: We have to explicitly extend the environment here because
-                     -- tcDefaultAssocDecl will pull on the fam_tc when checking the default instance,
-                     -- and the the version of the fam_tc currently present in the environment is _|_
-                     tcExtendGlobalEnv [ATyCon fam_tc] $
-                       tcDefaultAssocDecl clas_tvs def_decl) def_decls
+                   liftM Just $ mapM (tcDefaultAssocDecl fam_tc clas_tvs) def_decls
         return (fam_tc, dat)
 \end{code}
 
@@ -708,35 +703,16 @@ tcFamInstDecl1 :: TyCon -> TyClDecl Name -> TcM TyCon
 
   -- "type instance"
 tcFamInstDecl1 fam_tc (decl@TySynonym {})
-  = kcIdxTyPats fam_tc decl $ \k_tvs k_typats resKind ->
-    do { -- check that the family declaration is for a synonym
-         checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc)
-
-       ; -- (1) kind check the right-hand side of the type equation
-       ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
-                  -- ToDo: the ExpKind could be better
-
-         -- we need the exact same number of type parameters as the family
-         -- declaration
-       ; let famArity = tyConArity fam_tc
-       ; checkTc (length k_typats == famArity) $
-                 wrongNumberOfParmsErr famArity
+  = do { -- (1) do the work of verifying the synonym
+       ; (t_tvs, t_typats, t_rhs) <- tcFamSynInstDecl1 fam_tc decl
 
-         -- (2) type check type equation
-       ; tcTyVarBndrs k_tvs $ \t_tvs -> do   -- turn kinded into proper tyvars
-       { t_typats <- mapM tcHsKindedType k_typats
-       ; t_rhs    <- tcHsKindedType k_rhs
-
-         -- (3) check the well-formedness of the instance
-       ; checkValidTypeInst t_typats t_rhs
-
-         -- (4) construct representation tycon
+         -- (2) construct representation tycon
        ; rep_tc_name <- newFamInstTyConName (tcdLName decl) t_typats
        ; buildSynTyCon rep_tc_name t_tvs
                        (SynonymTyCon t_rhs)
                        (typeKind t_rhs)
                        NoParentTyCon (Just (fam_tc, t_typats))
-       }}
+       }
 
   -- "newtype instance" and "data instance"
 tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data
@@ -796,6 +772,34 @@ tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data
                         _ -> True
 
 tcFamInstDecl1 _ d = pprPanic "tcFamInstDecl1" (ppr d)
+
+
+tcFamSynInstDecl1 :: TyCon -> TyClDecl Name -> TcM ([TyVar], [Type], Type)
+tcFamSynInstDecl1 fam_tc (decl@TySynonym {})
+  = kcIdxTyPats fam_tc decl $ \k_tvs k_typats resKind ->
+    do { -- check that the family declaration is for a synonym
+         checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc)
+
+       ; -- (1) kind check the right-hand side of the type equation
+       ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
+                  -- ToDo: the ExpKind could be better
+
+         -- we need the exact same number of type parameters as the family
+         -- declaration
+       ; let famArity = tyConArity fam_tc
+       ; checkTc (length k_typats == famArity) $
+                 wrongNumberOfParmsErr famArity
+
+         -- (2) type check type equation
+       ; tcTyVarBndrs k_tvs $ \t_tvs -> do   -- turn kinded into proper tyvars
+       { t_typats <- mapM tcHsKindedType k_typats
+       ; t_rhs    <- tcHsKindedType k_rhs
+
+         -- (3) check the well-formedness of the instance
+       ; checkValidTypeInst t_typats t_rhs
+
+       ; return (t_tvs, t_typats, t_rhs) }}
+tcFamSynInstDecl1 _ decl = pprPanic "tcFamSynInstDecl1" (ppr decl)
 \end{code}
 
 %************************************************************************
@@ -836,21 +840,22 @@ tcAssocDecl clas mini_env (L loc decl)
       = return ()   -- Allow non-type-variable instantiation
                     -- See Note [Associated type instances]
 
-tcDefaultAssocDecl :: [TyVar]        -- ^ TyVars of associated type's class
-                   -> LTyClDecl Name -- ^ RHS
-                   -> TcM TyCon
-tcDefaultAssocDecl clas_tvs (L loc decl)
+tcDefaultAssocDecl :: TyCon                       -- ^ Family TyCon
+                   -> [TyVar]                     -- ^ TyVars of associated type's class
+                   -> LTyClDecl Name              -- ^ RHS
+                   -> TcM ([TyVar], [Type], Type) -- ^ Type checked RHS and free TyVars
+tcDefaultAssocDecl fam_tc clas_tvs (L loc decl)
   = setSrcSpan loc      $
     tcAddDeclCtxt decl  $
-    do { at_tc <- tcFamInstDecl NotTopLevel decl
-       ; let Just (_fam_tc, at_tys) = tyConFamInst_maybe at_tc
-  
+    do { (at_tvs, at_tys, at_rhs) <- tcFamSynInstDecl1 fam_tc decl
+       ; checkValidType (TySynCtxt (tyConName fam_tc)) at_rhs
+       
        -- See Note [Checking consistent instantiation]
        -- We only want to check this on the *class* TyVars,
        -- not the *family* TyVars (there may be more of these)
        ; zipWithM_ check_arg clas_tvs at_tys
 
-       ; return at_tc }
+       ; return (at_tvs, at_tys, at_rhs) }
   where
     check_arg fam_tc_tv at_ty
       = checkTc (mkTyVarTy fam_tc_tv `eqType` at_ty) 
diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs
index ba20555494..a64d879f88 100644
--- a/compiler/types/Class.lhs
+++ b/compiler/types/Class.lhs
@@ -24,7 +24,7 @@ module Class (
 #include "HsVersions.h"
 
 import {-# SOURCE #-} TyCon	( TyCon )
-import {-# SOURCE #-} TypeRep	( PredType )
+import {-# SOURCE #-} TypeRep	( Type, PredType )
 
 import Var
 import Name
@@ -85,9 +85,13 @@ data DefMeth = NoDefMeth 		-- No default method
 	     | GenDefMeth Name 		-- A generic default method
              deriving Eq
 
-type ClassATItem = (TyCon, Maybe [TyCon])
+type ClassATItem = (TyCon, Maybe [([TyVar], [Type], Type)])
   -- Nothing  => No default associated type
-  -- Just tcs => Default associated types from these templates
+  -- Just tcs => Default associated types from these templates.
+  -- Each template is a triple of:
+  --   1. TyVars of the RHS and family arguments (including the class TVs)
+  --   3. The instantiated family arguments
+  --   2. The RHS of the synonym
 
 -- | Convert a `DefMethSpec` to a `DefMeth`, which discards the name field in
 --   the `DefMeth` constructor of the `DefMeth`.
diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs
index c5f1c0c2ed..6a15896fcb 100644
--- a/compiler/utils/Util.lhs
+++ b/compiler/utils/Util.lhs
@@ -44,7 +44,7 @@ module Util (
         sortLe, sortWith, minWith, on,
 
         -- * Comparisons
-        isEqual, eqListBy,
+        isEqual, eqListBy, eqMaybeBy,
         thenCmp, cmpList,
         removeSpaces,
         
@@ -677,6 +677,11 @@ eqListBy _  []     []     = True
 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
 eqListBy _  _      _      = False
 
+eqMaybeBy :: (a ->a->Bool) -> Maybe a -> Maybe a -> Bool
+eqMaybeBy _  Nothing  Nothing  = True
+eqMaybeBy eq (Just x) (Just y) = eq x y
+eqMaybeBy _  _        _        = False
+
 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
     -- `cmpList' uses a user-specified comparer