Extend Class.Class to include the TyCons of ATs

Mon Sep 18 18:58:51 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Extend Class.Class to include the TyCons of ATs
  Wed Aug 16 16:15:31 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * Extend Class.Class to include the TyCons of ATs

compiler/iface/BinIface.hs

@@ -919,7 +919,7 @@ instance Binary IfaceDecl where
 	    put_ bh ar
 	    put_ bh as
 	    put_ bh at
-    put_ bh (IfaceClass a1 a2 a3 a4 a5 a6) = do
+    put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
 	    putByte bh 4
 	    put_ bh a1
 	    put_ bh a2
@@ -927,6 +927,7 @@ instance Binary IfaceDecl where
 	    put_ bh a4
 	    put_ bh a5
 	    put_ bh a6
+	    put_ bh a7
     get bh = do
 	    h <- getByte bh
 	    case h of
@@ -957,7 +958,8 @@ instance Binary IfaceDecl where
 		    a4 <- get bh
 		    a5 <- get bh
 		    a6 <- get bh
-		    return (IfaceClass a1 a2 a3 a4 a5 a6)
+		    a7 <- get bh
+		    return (IfaceClass a1 a2 a3 a4 a5 a6 a7)
 
 instance Binary IfaceInst where
     put_ bh (IfaceInst cls tys dfun flag orph) = do

compiler/iface/BuildTyCl.lhs

@@ -37,6 +37,7 @@ import Type		( mkArrowKinds, liftedTypeKind, typeKind,
 			  splitTyConApp_maybe, splitAppTy_maybe,
 			  getTyVar_maybe, 
 			  mkPredTys, mkTyVarTys, ThetaType, Type, Kind,
+			  TyThing(..), 
 			  substTyWith, zipTopTvSubst, substTheta, mkForAllTys,
                           mkTyConApp, mkTyVarTy )
 import Coercion         ( mkNewTypeCoercion )
@@ -231,11 +232,12 @@ mkTyConSelIds tycon rhs
 \begin{code}
 buildClass :: Name -> [TyVar] -> ThetaType
 	   -> [FunDep TyVar]		-- Functional dependencies
+	   -> [TyThing]			-- Associated types
 	   -> [(Name, DefMeth, Type)]	-- Method info
 	   -> RecFlag			-- Info for type constructor
 	   -> TcRnIf m n Class
 
-buildClass class_name tvs sc_theta fds sig_stuff tc_isrec
+buildClass class_name tvs sc_theta fds ats sig_stuff tc_isrec
   = do	{ tycon_name <- newImplicitBinder class_name mkClassTyConOcc
 	; datacon_name <- newImplicitBinder class_name mkClassDataConOcc
 		-- The class name is the 'parent' for this datacon, not its tycon,
@@ -285,10 +287,12 @@ buildClass class_name tvs sc_theta fds sig_stuff tc_isrec
 		-- Because C has only one operation, it is represented by
 		-- a newtype, and it should be a *recursive* newtype.
 		-- [If we don't make it a recursive newtype, we'll expand the
-		-- newtype like a synonym, but that will lead to an infinite type]
+		-- newtype like a synonym, but that will lead to an infinite
+		-- type]
+	      ; atTyCons = [tycon | ATyCon tycon <- ats]
 	      }
-	; return (mkClass class_name tvs fds
-		       sc_theta sc_sel_ids op_items
+	; return (mkClass class_name tvs fds 
+		       sc_theta sc_sel_ids atTyCons op_items
 		       tycon)
 	})}
 \end{code}

compiler/iface/IfaceSyn.lhs

@@ -93,6 +93,7 @@ data IfaceDecl
 		 ifName    :: OccName,		-- Name of the class
 		 ifTyVars  :: [IfaceTvBndr],	-- Type variables
 		 ifFDs     :: [FunDep FastString], -- Functional dependencies
+		 ifATs	   :: [IfaceDecl],	-- Associated type families
 		 ifSigs    :: [IfaceClassOp],	-- Method signatures
 	         ifRec	   :: RecFlag		-- Is newtype/datatype associated with the class recursive?
     }
@@ -260,10 +261,12 @@ pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
 		IfOpenNewTyCon 	-> ptext SLIT("newtype family")
 
 pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, 
-			  ifFDs = fds, ifSigs = sigs, ifRec = isrec})
+			  ifFDs = fds, ifATs = ats, ifSigs = sigs, 
+			  ifRec = isrec})
   = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
        4 (vcat [pprRec isrec,
-	        sep (map ppr sigs)])
+	        sep (map ppr ats),
+		sep (map ppr sigs)])
 
 pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec
 pprGen True  = ptext SLIT("Generics: yes")
@@ -546,6 +549,7 @@ eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {})
     eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> 
    	  eq_ifContext env (ifCtxt d1) (ifCtxt d2)  &&&
 	  eqListBy (eq_hsFD env)    (ifFDs d1)  (ifFDs d2) &&&
+	  eqListBy eqIfDecl         (ifATs d1)  (ifATs d2) &&&
 	  eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2)
        )
 

compiler/iface/MkIface.lhs

@@ -997,10 +997,12 @@ tyThingToIfaceDecl ext (AClass clas)
 		 ifName	  = getOccName clas,
 		 ifTyVars = toIfaceTvBndrs clas_tyvars,
 		 ifFDs    = map toIfaceFD clas_fds,
+		 ifATs	  = map (tyThingToIfaceDecl ext . ATyCon) clas_ats,
 		 ifSigs	  = map toIfaceClassOp op_stuff,
 	  	 ifRec    = boolToRecFlag (isRecursiveTyCon tycon) }
   where
-    (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
+    (clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff) 
+      = classExtraBigSig clas
     tycon = classTyCon clas
 
     toIfaceClassOp (sel_id, def_meth)

compiler/main/HscTypes.lhs

@@ -82,7 +82,7 @@ import CoreSyn		( CoreBind )
 import Id		( Id )
 import Type		( TyThing(..) )
 
-import Class		( Class, classSelIds, classTyCon )
+import Class		( Class, classSelIds, classTyCon, classATs )
 import TyCon		( TyCon, tyConSelIds, tyConDataCons, isNewTyCon, newTyConCo )
 import DataCon		( dataConImplicitIds )
 import PrelNames	( gHC_PRIM )
@@ -633,7 +633,8 @@ implicitTyThings (ATyCon tc) = implicitNewCoTyCon tc ++
 	-- For classes, add the class TyCon too (and its extras)
 	-- and the class selector Ids
 implicitTyThings (AClass cl) = map AnId (classSelIds cl) ++
-			       extras_plus (ATyCon (classTyCon cl))
+			       extras_plus (ATyCon (classTyCon cl)) ++
+			       map ATyCon (classATs cl)
 			 
 
 	-- For data cons add the worker and wrapper (if any)

compiler/parser/Parser.y.pp

@@ -39,6 +39,7 @@ import OrdList
 
 import FastString
 import Maybes		( orElse )
+import Monad            ( when )
 import Outputable
 import GLAEXTS
 }
@@ -483,7 +484,7 @@ cl_decl :: { LTyClDecl RdrName }
 				   (mkClassDecl (ctxt, tc, tvs) 
 					        (unLoc $3) sigs binds ats) } }
 
--- Type declarations
+-- Type declarations (toplevel)
 --
 ty_decl :: { LTyClDecl RdrName }
            -- ordinary type synonyms
@@ -520,7 +521,7 @@ ty_decl :: { LTyClDecl RdrName }
 				  (TySynonym tc tvs (Just typats) $5)) 
                       } }
 
-        -- ordinary data type or newtype declaration
+          -- ordinary data type or newtype declaration
 	| data_or_newtype tycl_hdr constrs deriving
 		{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
                       ; checkTyVars tparms    -- no type pattern
@@ -531,7 +532,7 @@ ty_decl :: { LTyClDecl RdrName }
 			    (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) 
 			       Nothing (reverse (unLoc $3)) (unLoc $4)) } }
 
-        -- ordinary GADT declaration
+          -- ordinary GADT declaration
         | data_or_newtype tycl_hdr opt_kind_sig 
 		 'where' gadt_constrlist
 		 deriving
@@ -542,7 +543,7 @@ ty_decl :: { LTyClDecl RdrName }
 			    (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) $3
 			      (reverse (unLoc $5)) (unLoc $6)) } }
 
-        -- data/newtype family
+          -- data/newtype family
         | data_or_newtype 'family' tycl_hdr '::' kind
 		{% do { let {(ctxt, tc, tvs, tparms) = unLoc $3}
                       ; checkTyVars tparms    -- no type pattern
@@ -551,7 +552,7 @@ ty_decl :: { LTyClDecl RdrName }
 			    (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) 
 			      (Just (unLoc $5)) [] Nothing) } }
 
-        -- data/newtype instance declaration
+          -- data/newtype instance declaration
 	| data_or_newtype 'instance' tycl_hdr constrs deriving
 		{% do { let {(ctxt, tc, tvs, tparms) = unLoc $3}
                                              -- can have type pats
@@ -562,7 +563,7 @@ ty_decl :: { LTyClDecl RdrName }
 			    (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms) 
 			      Nothing (reverse (unLoc $4)) (unLoc $5)) } }
 
-        -- GADT instance declaration
+          -- GADT instance declaration
         | data_or_newtype 'instance' tycl_hdr opt_kind_sig 
 		 'where' gadt_constrlist
 		 deriving
@@ -573,6 +574,62 @@ ty_decl :: { LTyClDecl RdrName }
 			    (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms) 
 			       $4 (reverse (unLoc $6)) (unLoc $7)) } }
 
+-- Associate type declarations
+--
+at_decl :: { LTyClDecl RdrName }
+           -- type family declarations
+        : 'type' opt_iso type '::' kind
+		-- Note the use of type for the head; this allows
+		-- infix type constructors to be declared
+		--
+ 		{% do { (tc, tvs, _) <- checkSynHdr $3 False
+		      ; return (L (comb3 $1 $3 $5) 
+				  (TyFunction tc tvs $2 (unLoc $5)))
+		      } }
+
+           -- type instance declarations
+        | 'type' opt_iso type '=' ctype
+		-- Note the use of type for the head; this allows
+		-- infix type constructors and type patterns
+		--
+ 		{% do { when $2 $ 
+			  parseError (comb2 $1 $>) "Misplaced iso keyword"
+		      ; (tc, tvs, typats) <- checkSynHdr $3 True
+		      ; return (L (comb2 $1 $5) 
+				  (TySynonym tc tvs (Just typats) $5)) 
+                      } }
+
+          -- data/newtype family
+        | data_or_newtype tycl_hdr '::' kind
+		{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
+                      ; checkTyVars tparms    -- no type pattern
+		      ; return $
+			  L (comb3 $1 $2 $4)
+			    (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) 
+			      (Just (unLoc $4)) [] Nothing) } }
+
+        -- data/newtype instance declaration
+	| data_or_newtype tycl_hdr constrs deriving
+		{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
+                                             -- can have type pats
+		      ; return $
+			  L (comb4 $1 $2 $3 $4)
+			           -- We need the location on tycl_hdr in case 
+				   -- constrs and deriving are both empty
+			    (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms) 
+			      Nothing (reverse (unLoc $3)) (unLoc $4)) } }
+
+        -- GADT instance declaration
+        | data_or_newtype tycl_hdr opt_kind_sig 
+		 'where' gadt_constrlist
+		 deriving
+		{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
+                                             -- can have type pats
+		      ; return $
+			  L (comb4 $1 $2 $5 $6)
+			    (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms) 
+			     $3 (reverse (unLoc $5)) (unLoc $6)) } }
+
 opt_iso :: { Bool }
 	:       { False }
 	| 'iso'	{ True  }
@@ -605,7 +662,7 @@ tycl_hdr :: { Located (LHsContext RdrName,
 -- Type declaration or value declaration
 --
 tydecl  :: { Located (OrdList (LHsDecl RdrName)) }
-tydecl  : ty_decl		        { LL (unitOL (L1 (TyClD (unLoc $1)))) }
+tydecl  : at_decl		        { LL (unitOL (L1 (TyClD (unLoc $1)))) }
 	| decl                          { $1 }
 
 tydecls	:: { Located (OrdList (LHsDecl RdrName)) }	-- Reversed

compiler/typecheck/TcSplice.lhs

@@ -631,7 +631,7 @@ reifyClass cls
 	; ops <- mapM reify_op op_stuff
 	; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
   where
-    (tvs, fds, theta, _, op_stuff) = classExtraBigSig cls
+    (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
     fds' = map reifyFunDep fds
     reify_op (op, _) = do { ty <- reifyType (idType op)
 			  ; return (TH.SigD (reifyName op) ty) }

compiler/typecheck/TcTyClsDecls.lhs

@@ -256,11 +256,11 @@ tcIdxTyInstDecl1 :: TyClDecl Name -> TcM (Maybe InstInfo)  -- Nothing if error
 
 tcIdxTyInstDecl1 (decl@TySynonym {})
   = kcIdxTyPats decl $ \k_tvs k_typats resKind ->
-    do { -- kind check the right hand side of the type equation
+    do { -- (1) kind check the right hand side of the type equation
        ; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind
 
-         -- type check type equation
-       ; tcTyVarBndrs k_tvs $ \t_tvs -> do {
+         -- (2) type check type equation
+       ; tcTyVarBndrs k_tvs $ \t_tvs -> do {  -- turn kinded into proper tyvars
        ; t_typats <- mappM tcHsKindedType k_typats
        ; t_rhs    <- tcHsKindedType k_rhs
 
@@ -272,17 +272,16 @@ tcIdxTyInstDecl1 (decl@TySynonym {})
 tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L _ tc_name,
 			       tcdCons = cons})
   = kcIdxTyPats decl $ \k_tvs k_typats resKind ->
-    do { -- kind check the data declaration as usual
+    do { -- (1) kind check the data declaration as usual
        ; k_decl <- kcDataDecl decl k_tvs
-       ; k_typats <- mappM tcHsKindedType k_typats
        ; let k_ctxt = tcdCtxt decl
 	     k_cons = tcdCons decl
 
          -- result kind must be '*' (otherwise, we have too few patterns)
        ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr tc_name
 
-         -- type check indexed data type declaration
-       ; tcTyVarBndrs k_tvs $ \t_tvs -> do {
+         -- (2) type check indexed data type declaration
+       ; tcTyVarBndrs k_tvs $ \t_tvs -> do {  -- turn kinded into proper tyvars
        ; unbox_strict <- doptM Opt_UnboxStrictFields
 
 	 -- Check that we don't use GADT syntax for indexed types
@@ -292,6 +291,7 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L _ tc_name,
        ; checkTc (new_or_data == DataType || isSingleton cons) $
 	   newtypeConError tc_name (length cons)
 
+       ; t_typats     <- mappM tcHsKindedType k_typats
        ; stupid_theta <- tcHsKindedContext k_ctxt
        ; tycon <- fixM (\ tycon -> do 
 	     { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data 
@@ -691,7 +691,6 @@ tcTyClDecl1 calc_isrec
   { ctxt' <- tcHsKindedContext ctxt
   ; fds' <- mappM (addLocM tc_fundep) fundeps
   ; ats' <- mappM (addLocM (tcTyClDecl1 (const Recursive))) ats
- -- ^^^^ !!!TODO: what to do with this?  Need to generate FC tyfun decls.
   ; sig_stuff <- tcClassSigs class_name sigs meths
   ; clas <- fixM (\ clas ->
 		let 	-- This little knot is just so we can get
@@ -700,7 +699,7 @@ tcTyClDecl1 calc_isrec
 		    tycon_name = tyConName (classTyCon clas)
 		    tc_isrec = calc_isrec tycon_name
 		in
-		buildClass class_name tvs' ctxt' fds' 
+		buildClass class_name tvs' ctxt' fds' ats'
 			   sig_stuff tc_isrec)
   ; return (AClass clas) }
   where

compiler/types/Class.lhs

@@ -11,7 +11,7 @@ module Class (
 	FunDep,	pprFundeps,
 
 	mkClass, classTyVars, classArity,
-	classKey, className, classSelIds, classTyCon, classMethods,
+	classKey, className, classATs, classSelIds, classTyCon, classMethods,
 	classBigSig, classExtraBigSig, classTvsFds, classSCTheta
     ) where
 
@@ -38,24 +38,27 @@ A @Class@ corresponds to a Greek kappa in the static semantics:
 \begin{code}
 data Class
   = Class {
-	classKey  :: Unique,			-- Key for fast comparison
+	classKey  :: Unique,		-- Key for fast comparison
 	className :: Name,
 	
-	classTyVars  :: [TyVar],		-- The class type variables
-	classFunDeps :: [FunDep TyVar],		-- The functional dependencies
+	classTyVars  :: [TyVar],	-- The class type variables
+	classFunDeps :: [FunDep TyVar],	-- The functional dependencies
 
-	classSCTheta :: [PredType],		-- Immediate superclasses, and the
-	classSCSels  :: [Id],			-- corresponding selector functions to
-						-- extract them from a dictionary of this
-						-- class
+	classSCTheta :: [PredType],	-- Immediate superclasses, and the
+	classSCSels  :: [Id],		-- corresponding selector functions
+					-- to extract them from a dictionary
+					-- of this class
 
-	classOpStuff :: [ClassOpItem],		-- Ordered by tag
+        classATs     :: [TyCon],	-- Associated type families
 
-	classTyCon :: TyCon		-- The data type constructor for dictionaries
-  }					-- of this class
+	classOpStuff :: [ClassOpItem],	-- Ordered by tag
 
-type FunDep a	  = ([a],[a])	--  e.g. class C a b c |  a b -> c, a c -> b  where ...
-				--  Here fun-deps are [([a,b],[c]), ([a,c],[b])]
+	classTyCon :: TyCon		-- The data type constructor for
+					-- dictionaries of this class
+     }
+
+type FunDep a = ([a],[a])  --  e.g. class C a b c | a b -> c, a c -> b where...
+			   --  Here fun-deps are [([a,b],[c]), ([a,c],[b])]
 
 type ClassOpItem = (Id, DefMeth)
 	-- Selector function; contains unfolding
@@ -73,11 +76,12 @@ The @mkClass@ function fills in the indirect superclasses.
 mkClass :: Name -> [TyVar]
 	-> [([TyVar], [TyVar])]
 	-> [PredType] -> [Id]
+	-> [TyCon]
 	-> [ClassOpItem]
 	-> TyCon
 	-> Class
 
-mkClass name tyvars fds super_classes superdict_sels
+mkClass name tyvars fds super_classes superdict_sels ats 
 	op_stuff tycon
   = Class {	classKey = getUnique name, 
 		className = name,
@@ -85,6 +89,7 @@ mkClass name tyvars fds super_classes superdict_sels
 		classFunDeps = fds,
 		classSCTheta = super_classes,
 		classSCSels = superdict_sels,
+		classATs = ats,
 		classOpStuff = op_stuff,
 		classTyCon = tycon }
 \end{code}
@@ -118,8 +123,8 @@ classBigSig (Class {classTyVars = tyvars, classSCTheta = sc_theta,
   = (tyvars, sc_theta, sc_sels, op_stuff)
 classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
 			 classSCTheta = sc_theta, classSCSels = sc_sels,
-			 classOpStuff = op_stuff})
-  = (tyvars, fundeps, sc_theta, sc_sels, op_stuff)
+			 classATs = ats, classOpStuff = op_stuff})
+  = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff)
 \end{code}