Generating synonym instance representation tycons

- Type synonym instances are turned into representation synonym tycons
- They are entered into the pool of family instances (FamInst environments)
  in the same way as data/newtype instances
- Still missing is writing the parent tycon information into ifaces and 
  various well-formedness checks.

compiler/iface/BuildTyCl.lhs

@@ -36,16 +36,29 @@ import Data.List
 
 \begin{code}
 ------------------------------------------------------
-buildSynTyCon :: Name -> [TyVar] -> SynTyConRhs -> TyCon
-buildSynTyCon name tvs rhs@(OpenSynTyCon rhs_ki _)
-  = mkSynTyCon name kind tvs rhs
-  where
-    kind = mkArrowKinds (map tyVarKind tvs) rhs_ki
-buildSynTyCon name tvs rhs@(SynonymTyCon rhs_ty)
-  = mkSynTyCon name kind tvs rhs
-  where
-    kind = mkArrowKinds (map tyVarKind tvs) (typeKind rhs_ty)
+buildSynTyCon :: Name -> [TyVar] 
+              -> SynTyConRhs 
+	      -> Maybe (TyCon, [Type])  -- family instance if applicable
+              -> TcRnIf m n TyCon
 
+buildSynTyCon tc_name tvs rhs@(OpenSynTyCon rhs_ki _) _
+  = let
+      kind = mkArrowKinds (map tyVarKind tvs) rhs_ki
+    in
+    return $ mkSynTyCon tc_name kind tvs rhs NoParentTyCon
+    
+buildSynTyCon tc_name tvs rhs@(SynonymTyCon rhs_ty) mb_family
+  = do { -- We need to tie a knot as the coercion of a data instance depends
+	 -- on the instance representation tycon and vice versa.
+       ; tycon <- fixM (\ tycon_rec -> do 
+	 { parent <- mkParentInfo mb_family tc_name tvs tycon_rec
+	 ; let { tycon   = mkSynTyCon tc_name kind tvs rhs parent
+	       ; kind    = mkArrowKinds (map tyVarKind tvs) (typeKind rhs_ty)
+	       }
+         ; return tycon
+         })
+       ; return tycon 
+       }
 
 ------------------------------------------------------
 buildAlgTyCon :: Name -> [TyVar] 
@@ -62,7 +75,7 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
   = do { -- We need to tie a knot as the coercion of a data instance depends
 	 -- on the instance representation tycon and vice versa.
        ; tycon <- fixM (\ tycon_rec -> do 
-	 { parent <- parentInfo mb_family tycon_rec
+	 { parent <- mkParentInfo mb_family tc_name tvs tycon_rec
 	 ; let { tycon = mkAlgTyCon tc_name kind tvs stupid_theta rhs
 				    fields parent is_rec want_generics gadt_syn
 	       ; kind    = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
@@ -72,29 +85,32 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
          })
        ; return tycon 
        }
-  where
-    -- If a family tycon with instance types is given, the current tycon is an
-    -- instance of that family and we need to
-    --
-    -- (1) create a coercion that identifies the family instance type and the
-    --     representation type from Step (1); ie, it is of the form 
-    --	   `Co tvs :: F ts :=: R tvs', where `Co' is the name of the coercion,
-    --	   `F' the family tycon and `R' the (derived) representation tycon,
-    --	   and
-    -- (2) produce a `AlgTyConParent' value containing the parent and coercion
-    --     information.
-    --
-    parentInfo Nothing                  rep_tycon = 
-      return NoParentTyCon
-    parentInfo (Just (family, instTys)) rep_tycon =
-      do { -- Create the coercion
-	 ; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc
-	 ; let co_tycon = mkDataInstCoercion co_tycon_name tvs
-					     family instTys rep_tycon
-	 ; return $ FamilyTyCon family instTys co_tycon
-	 }
-    
 
+-- If a family tycon with instance types is given, the current tycon is an
+-- instance of that family and we need to
+--
+-- (1) create a coercion that identifies the family instance type and the
+--     representation type from Step (1); ie, it is of the form 
+--	   `Co tvs :: F ts :=: R tvs', where `Co' is the name of the coercion,
+--	   `F' the family tycon and `R' the (derived) representation tycon,
+--	   and
+-- (2) produce a `TyConParent' value containing the parent and coercion
+--     information.
+--
+mkParentInfo :: Maybe (TyCon, [Type]) 
+             -> Name -> [TyVar] 
+             -> TyCon 
+             -> TcRnIf m n TyConParent
+mkParentInfo Nothing                  _       _   _         =
+  return NoParentTyCon
+mkParentInfo (Just (family, instTys)) tc_name tvs rep_tycon =
+  do { -- Create the coercion
+     ; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc
+     ; let co_tycon = mkFamInstCoercion co_tycon_name tvs
+                                        family instTys rep_tycon
+     ; return $ FamilyTyCon family instTys co_tycon
+     }
+    
 ------------------------------------------------------
 mkAbstractTyConRhs :: AlgTyConRhs
 mkAbstractTyConRhs = AbstractTyCon

compiler/iface/TcIface.lhs

@@ -383,7 +383,9 @@ tcIfaceDecl ignore_prags
      ; rhs_tyki <- tcIfaceType rdr_rhs_ty
      ; let rhs = if isOpen then OpenSynTyCon rhs_tyki Nothing
 			   else SynonymTyCon rhs_tyki
-     ; return (ATyCon (buildSynTyCon tc_name tyvars rhs))
+     -- !!!TODO: read mb_family info from iface and pass as last argument
+     ; tycon <- buildSynTyCon tc_name tyvars rhs Nothing
+     ; return $ ATyCon tycon
      }
 
 tcIfaceDecl ignore_prags

compiler/prelude/TysWiredIn.lhs

@@ -69,7 +69,7 @@ import DataCon		( DataCon, mkDataCon, dataConWorkId, dataConSourceArity )
 import Var		( TyVar, tyVarKind )
 import TyCon		( TyCon, AlgTyConRhs(DataTyCon), tyConDataCons,
 			  mkTupleTyCon, mkAlgTyCon, tyConName,
-			  AlgTyConParent(NoParentTyCon) )
+			  TyConParent(NoParentTyCon) )
 
 import BasicTypes	( Arity, RecFlag(..), Boxity(..), isBoxed,
 			  StrictnessMark(..) )

compiler/typecheck/TcEnv.lhs

@@ -650,7 +650,7 @@ newDFunName clas (ty:_) loc
 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
 \end{code}
 
-Make a name for the representation tycon of a data/newtype instance.  It's an
+Make a name for the representation tycon of a family instance.  It's an
 *external* name, like otber top-level names, and hence must be made with
 newGlobalBinder.
 

compiler/typecheck/TcTyClsDecls.lhs

@@ -252,7 +252,8 @@ tcFamInstDecl (L loc decl)
 
 tcFamInstDecl1 :: TyClDecl Name -> TcM (Maybe TyThing)   -- Nothing if error
 
-tcFamInstDecl1 (decl@TySynonym {})
+  -- "type instance"
+tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
   = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
     do { -- check that the family declaration is for a synonym
 	 unless (isSynTyCon family) $
@@ -266,10 +267,15 @@ tcFamInstDecl1 (decl@TySynonym {})
        ; t_typats <- mappM tcHsKindedType k_typats
        ; t_rhs    <- tcHsKindedType k_rhs
 
-         -- !!!of the form: forall t_tvs. (tcdLName decl) t_typats = t_rhs
-       ; return Nothing     -- !!!TODO: need TyThing for indexed synonym
+         -- (3) construct representation tycon
+       ; rep_tc_name <- newFamInstTyConName tc_name (srcSpanStart loc)
+       ; tycon <- buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) 
+                                (Just (family, t_typats))
+
+       ; return $ Just (ATyCon tycon)
        }}
-      
+
+  -- "newtype instance" and "data instance"
 tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
 			     tcdCons = cons})
   = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
@@ -300,6 +306,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
        ; t_typats     <- mappM tcHsKindedType k_typats
        ; stupid_theta <- tcHsKindedContext k_ctxt
 
+         -- (3) construct representation tycon
        ; rep_tc_name <- newFamInstTyConName tc_name (srcSpanStart loc)
        ; tycon <- fixM (\ tycon -> do 
 	     { data_cons <- mappM (addLocM (tcConDecl unbox_strict tycon t_tvs))
@@ -587,12 +594,15 @@ tcSynDecls (decl : decls)
        ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls decls)
        ; return (syn_tc : syn_tcs) }
 
+  -- "type"
 tcSynDecl
   (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
   = tcTyVarBndrs tvs		$ \ tvs' -> do 
     { traceTc (text "tcd1" <+> ppr tc_name) 
     ; rhs_ty' <- tcHsKindedType rhs_ty
-    ; return (ATyCon (buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty'))) }
+    ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') Nothing
+    ; return (ATyCon tycon) 
+    }
 
 --------------------
 tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
@@ -614,7 +624,8 @@ tcTyClDecl1 _calc_isrec
 	-- Check that we don't use families without -findexed-types
   ; checkTc idx_tys $ badFamInstDecl tc_name
 
-  ; return [ATyCon $ buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing)]
+  ; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) Nothing
+  ; return [ATyCon tycon]
   }
 
   -- "newtype family" or "data family" declaration
@@ -639,7 +650,7 @@ tcTyClDecl1 _calc_isrec
   ; return [ATyCon tycon]
   }
 
-  -- "newtype", "data", "newtype instance", "data instance"
+  -- "newtype" and "data"
 tcTyClDecl1 calc_isrec
   (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
 	   tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons})

compiler/types/Coercion.lhs

@@ -25,7 +25,7 @@ module Coercion (
         mkSymCoercion, mkTransCoercion,
         mkLeftCoercion, mkRightCoercion, mkInstCoercion, mkAppCoercion,
         mkForAllCoercion, mkFunCoercion, mkInstsCoercion, mkUnsafeCoercion,
-        mkNewTypeCoercion, mkDataInstCoercion, mkAppsCoercion,
+        mkNewTypeCoercion, mkFamInstCoercion, mkAppsCoercion,
 
         splitNewTypeRepCo_maybe, decomposeCo,
 
@@ -294,18 +294,18 @@ mkNewTypeCoercion name tycon tvs rhs_ty
     rule args = ASSERT( co_con_arity == length args )
 		(TyConApp tycon args, substTyWith tvs args rhs_ty)
 
--- Coercion identifying a data/newtype representation type and its family
--- instance.  It has the form `Co tvs :: F ts :=: R tvs', where `Co' is the
--- coercion tycon built here, `F' the family tycon and `R' the (derived)
+-- Coercion identifying a data/newtype/synonym representation type and its 
+-- family instance.  It has the form `Co tvs :: F ts :=: R tvs', where `Co' is 
+-- the coercion tycon built here, `F' the family tycon and `R' the (derived)
 -- representation tycon.
 --
-mkDataInstCoercion :: Name	-- unique name for the coercion tycon
-		   -> [TyVar]	-- type parameters of the coercion (`tvs')
-		   -> TyCon	-- family tycon (`F')
-		   -> [Type]	-- type instance (`ts')
-		   -> TyCon	-- representation tycon (`R')
-		   -> TyCon	-- => coercion tycon (`Co')
-mkDataInstCoercion name tvs family instTys rep_tycon
+mkFamInstCoercion :: Name	-- unique name for the coercion tycon
+		  -> [TyVar]	-- type parameters of the coercion (`tvs')
+		  -> TyCon	-- family tycon (`F')
+		  -> [Type]	-- type instance (`ts')
+		  -> TyCon	-- representation tycon (`R')
+		  -> TyCon	-- => coercion tycon (`Co')
+mkFamInstCoercion name tvs family instTys rep_tycon
   = mkCoercionTyCon name coArity rule
   where
     coArity = length tvs

compiler/types/FamInstEnv.lhs

@@ -51,7 +51,7 @@ data FamInst
 
 		-- Used for "rough matching"; same idea as for class instances
 	    , fi_tcs   :: [Maybe Name]	-- Top of type args
-		-- INVARIANT: fi_tcs = roughMatchTcs is_tys
+		-- INVARIANT: fi_tcs = roughMatchTcs fi_tys
 
 		-- Used for "proper matching"; ditto
 	    , fi_tvs   :: TyVarSet	-- Template tyvars for full match

compiler/types/TyCon.lhs

@@ -13,7 +13,7 @@ module TyCon(
 	tyConPrimRep,
 
 	AlgTyConRhs(..), visibleDataCons, 
-        AlgTyConParent(..), 
+        TyConParent(..), 
 	SynTyConRhs(..),
 
 	isFunTyCon, isUnLiftedTyCon, isProductTyCon, 
@@ -125,7 +125,7 @@ data TyCon
 	hasGenerics :: Bool,		-- True <=> generic to/from functions are available
 					-- (in the exports of the data type's source module)
 
-	algTcParent :: AlgTyConParent	-- Gives the class or family tycon for
+	algTcParent :: TyConParent	-- Gives the class or family tycon for
 					-- derived tycons representing classes
 					-- or family instances, respectively.
     }
@@ -149,7 +149,12 @@ data TyCon
 
 	tyConTyVars  :: [TyVar],	-- Bound tyvars
 
-	synTcRhs     :: SynTyConRhs	-- Expanded type in here
+	synTcRhs     :: SynTyConRhs,	-- Expanded type in here
+
+        synTcParent  :: TyConParent     -- Gives the family tycon of
+                                        -- representation tycons of family
+                                        -- instances
+
     }
 
   | PrimTyCon {			-- Primitive types; cannot be defined in Haskell
@@ -262,12 +267,13 @@ visibleDataCons OpenTyCon {}		      = []
 visibleDataCons (DataTyCon{ data_cons = cs }) = cs
 visibleDataCons (NewTyCon{ data_con = c })    = [c]
 
--- Both type classes as well as data/newtype family instances imply implicit
--- type constructors.  These implicit type constructors refer to their parent
+-- Both type classes as well as family instances imply implicit type 
+-- constructors.  These implicit type constructors refer to their parent
 -- structure (ie, the class or family from which they derive) using a type of
--- the following form.
+-- the following form.  We use `TyConParent' for both algebraic and synonym 
+-- types, but the variant `ClassTyCon' will only be used by algebraic tycons.
 --
-data AlgTyConParent 
+data TyConParent 
   = NoParentTyCon	-- An ordinary type constructor has no parent.
 
   | ClassTyCon      	-- Type constructors representing a class dictionary.
@@ -297,7 +303,7 @@ data SynTyConRhs
 
   | SynonymTyCon Type   -- Mentioning head type vars.  Acts as a template for
 			--  the expansion when the tycon is applied to some
-			--  types.  
+			--  types.
 \end{code}
 
 Note [Newtype coercions]
@@ -498,14 +504,15 @@ mkPrimTyCon' name kind arity rep is_unlifted
 	tyConExtName = Nothing
     }
 
-mkSynTyCon name kind tyvars rhs
+mkSynTyCon name kind tyvars rhs parent
   = SynTyCon {	
 	tyConName = name,
 	tyConUnique = nameUnique name,
 	tyConKind = kind,
 	tyConArity = length tyvars,
 	tyConTyVars = tyvars,
-	synTcRhs = rhs
+	synTcRhs = rhs,
+        synTcParent = parent
     }
 
 mkCoercionTyCon name arity kindRule
@@ -860,17 +867,22 @@ tyConClass_maybe other_tycon				    = Nothing
 
 isFamInstTyCon :: TyCon -> Bool
 isFamInstTyCon (AlgTyCon {algTcParent = FamilyTyCon _ _ _ }) = True
+isFamInstTyCon (SynTyCon {synTcParent = FamilyTyCon _ _ _ }) = True
 isFamInstTyCon other_tycon			             = False
 
 tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type])
 tyConFamInst_maybe (AlgTyCon {algTcParent = FamilyTyCon fam instTys _}) = 
   Just (fam, instTys)
+tyConFamInst_maybe (SynTyCon {synTcParent = FamilyTyCon fam instTys _}) = 
+  Just (fam, instTys)
 tyConFamInst_maybe other_tycon				                = 
   Nothing
 
 tyConFamilyCoercion_maybe :: TyCon -> Maybe TyCon
 tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = FamilyTyCon _ _ coe}) = 
   Just coe
+tyConFamilyCoercion_maybe (SynTyCon {synTcParent = FamilyTyCon _ _ coe}) = 
+  Just coe
 tyConFamilyCoercion_maybe other_tycon 				         = 
   Nothing
 \end{code}