Moved argument position info of ATs into tycon rhs info

compiler/iface/BuildTyCl.lhs

@@ -37,7 +37,7 @@ import Data.List
 \begin{code}
 ------------------------------------------------------
 buildSynTyCon :: Name -> [TyVar] -> SynTyConRhs -> TyCon
-buildSynTyCon name tvs rhs@(OpenSynTyCon rhs_ki)
+buildSynTyCon name tvs rhs@(OpenSynTyCon rhs_ki _)
   = mkSynTyCon name kind tvs rhs
   where
     kind = mkArrowKinds (map tyVarKind tvs) rhs_ki
@@ -100,10 +100,10 @@ mkAbstractTyConRhs :: AlgTyConRhs
 mkAbstractTyConRhs = AbstractTyCon
 
 mkOpenDataTyConRhs :: AlgTyConRhs
-mkOpenDataTyConRhs = OpenDataTyCon
+mkOpenDataTyConRhs = OpenTyCon Nothing False
 
 mkOpenNewTyConRhs :: AlgTyConRhs
-mkOpenNewTyConRhs = OpenNewTyCon
+mkOpenNewTyConRhs = OpenTyCon Nothing True
 
 mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
 mkDataTyConRhs cons

compiler/iface/MkIface.lhs

@@ -1085,16 +1085,16 @@ tyThingToIfaceDecl (ATyCon tycon)
   where
     tyvars = tyConTyVars tycon
     (syn_isOpen, syn_tyki) = case synTyConRhs tycon of
-			       OpenSynTyCon ki -> (True , ki)
-			       SynonymTyCon ty -> (False, ty)
+			       OpenSynTyCon ki _ -> (True , ki)
+			       SynonymTyCon ty   -> (False, ty)
 
-    ifaceConDecls (NewTyCon { data_con = con })    = 
+    ifaceConDecls (NewTyCon { data_con = con })     = 
       IfNewTyCon  (ifaceConDecl con)
-    ifaceConDecls (DataTyCon { data_cons = cons }) = 
+    ifaceConDecls (DataTyCon { data_cons = cons })  = 
       IfDataTyCon (map ifaceConDecl cons)
-    ifaceConDecls OpenDataTyCon                    = IfOpenDataTyCon
-    ifaceConDecls OpenNewTyCon                     = IfOpenNewTyCon
-    ifaceConDecls AbstractTyCon			   = IfAbstractTyCon
+    ifaceConDecls OpenTyCon { otIsNewtype = False } = IfOpenDataTyCon
+    ifaceConDecls OpenTyCon { otIsNewtype = True  } = IfOpenNewTyCon
+    ifaceConDecls AbstractTyCon			    = IfAbstractTyCon
 	-- The last case happens when a TyCon has been trimmed during tidying
 	-- Furthermore, tyThingToIfaceDecl is also used
 	-- in TcRnDriver for GHCi, when browsing a module, in which case the

compiler/iface/TcIface.lhs

@@ -380,7 +380,7 @@ tcIfaceDecl ignore_prags
    = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
      { tc_name <- lookupIfaceTop occ_name
      ; rhs_tyki <- tcIfaceType rdr_rhs_ty
-     ; let rhs = if isOpen then OpenSynTyCon rhs_tyki 
+     ; let rhs = if isOpen then OpenSynTyCon rhs_tyki Nothing
 			   else SynonymTyCon rhs_tyki
      ; return (ATyCon (buildSynTyCon tc_name tyvars rhs))
      }

compiler/typecheck/TcTyClsDecls.lhs

@@ -615,7 +615,7 @@ 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)]
+  ; return [ATyCon $ buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing)]
   }
 
   -- "newtype family" or "data family" declaration
@@ -634,8 +634,8 @@ tcTyClDecl1 _calc_isrec
 
   ; tycon <- buildAlgTyCon tc_name final_tvs [] 
 	       (case new_or_data of
-		  DataType -> OpenDataTyCon
-		  NewType  -> OpenNewTyCon)
+		  DataType -> mkOpenDataTyConRhs
+		  NewType  -> mkOpenNewTyConRhs)
 	       Recursive False True Nothing
   ; return [ATyCon tycon]
   }
@@ -945,8 +945,8 @@ checkValidTyCon :: TyCon -> TcM ()
 checkValidTyCon tc 
   | isSynTyCon tc 
   = case synTyConRhs tc of
-      OpenSynTyCon _  -> return ()
-      SynonymTyCon ty -> checkValidType syn_ctxt ty
+      OpenSynTyCon _ _ -> return ()
+      SynonymTyCon ty  -> checkValidType syn_ctxt ty
   | otherwise
   = 	-- Check the context on the data decl
     checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)	`thenM_` 

compiler/types/TyCon.lhs

@@ -108,15 +108,6 @@ data TyCon
 					--		   types if present
 					-- But not over the data constructors
 
-        tyConArgPoss :: Maybe [Int],    -- for associated families: for each
-					-- tyvar in the AT decl, gives the
-					-- position of that tyvar in the class
-					-- argument list (starting from 0).
-					-- NB: Length is less than tyConArity
-					--     if higher kind signature.
-					-- NB: Just _ <=> associated (not
-					--		  toplevel) family
-	
 	algTcSelIds :: [Id],  		-- Its record selectors (empty if none)
 
 	algTcGadtSyntax  :: Bool,	-- True <=> the data type was declared using GADT syntax
@@ -158,13 +149,6 @@ data TyCon
 
 	tyConTyVars  :: [TyVar],	-- Bound tyvars
 
-        tyConArgPoss :: Maybe [Int],    -- for associated families: for each
-					-- tyvar in the AT decl, gives the
-					-- position of that tyvar in the class
-					-- argument list (starting from 0).
-					-- NB: Length is less than tyConArity
-					--     if higher kind signature.
-	
 	synTcRhs     :: SynTyConRhs	-- Expanded type in here
     }
 
@@ -204,21 +188,37 @@ data TyCon
 
 type FieldLabel = Name
 
+-- Right hand sides of type constructors for algebraic types
+--
 data AlgTyConRhs
-  = AbstractTyCon	-- We know nothing about this data type, except 
-			-- that it's represented by a pointer
-			-- Used when we export a data type abstractly into
-			-- an hi file
 
-  | OpenDataTyCon       -- data family        (further instances can appear
-  | OpenNewTyCon        -- newtype family      at any time)
+  -- We know nothing about this data type, except that it's represented by a
+  -- pointer.  Used when we export a data type abstractly into an hi file.
+  --
+  = AbstractTyCon
+
+  -- The constructor represents an open family without a fixed right hand
+  -- side.  Additional instances can appear at any time.
+  --
+  | OpenTyCon {
+
+      otArgPoss   :: Maybe [Int],  
+	-- for associated families: for each tyvar in the AT decl, gives the
+	-- position of that tyvar in the class argument list (starting from 0).
+	-- NB: Length is less than tyConArity iff higher kind signature.
+	-- NB: Just _ <=> associated (not toplevel) family
+	
+      otIsNewtype :: Bool	     
+        -- is a newtype (rather than data type)?
+
+    }
 
   | DataTyCon {
 	data_cons :: [DataCon],
 			-- The constructors; can be empty if the user declares
 			--   the type to have no constructors
 			-- INVARIANT: Kept in order of increasing tag
-			--	      (see the tag assignment in DataCon.mkDataCon)
+			--	  (see the tag assignment in DataCon.mkDataCon)
 	is_enum :: Bool 	-- Cached: True <=> an enumeration type
     }			--	   Includes data types with no constructors.
 
@@ -257,8 +257,7 @@ data AlgTyConRhs
 
 visibleDataCons :: AlgTyConRhs -> [DataCon]
 visibleDataCons AbstractTyCon      	      = []
-visibleDataCons OpenDataTyCon		      = []
-visibleDataCons OpenNewTyCon		      = []
+visibleDataCons OpenTyCon {}		      = []
 visibleDataCons (DataTyCon{ data_cons = cs }) = cs
 visibleDataCons (NewTyCon{ data_con = c })    = [c]
 
@@ -286,7 +285,14 @@ data AlgTyConParent
 	-- with T77's algTcParent = FamilyTyCon T [a] co
 
 data SynTyConRhs
-  = OpenSynTyCon Kind	-- Type family: *result* kind given
+  = OpenSynTyCon Kind	        -- Type family: *result* kind given
+		 (Maybe [Int])  -- for associated families: for each tyvars in
+				-- the AT decl, gives the position of that
+				-- tyvar in the class argument list (starting
+				-- from 0). 
+				-- NB: Length is less than tyConArity
+				--     if higher kind signature.
+
   | SynonymTyCon Type   -- Mentioning head type vars.  Acts as a template for
 			--  the expansion when the tycon is applied to some
 			--  types.  
@@ -428,7 +434,6 @@ mkAlgTyCon name kind tyvars stupid rhs sel_ids parent is_rec gen_info gadt_syn
 	tyConKind	 = kind,
 	tyConArity	 = length tyvars,
 	tyConTyVars	 = tyvars,
-	tyConArgPoss	 = Nothing,
 	algTcStupidTheta = stupid,
 	algTcRhs         = rhs,
 	algTcSelIds	 = sel_ids,
@@ -498,7 +503,6 @@ mkSynTyCon name kind tyvars rhs
 	tyConKind = kind,
 	tyConArity = length tyvars,
 	tyConTyVars = tyvars,
-	tyConArgPoss = Nothing,
 	synTcRhs = rhs
     }
 
@@ -556,20 +560,20 @@ isDataTyCon :: TyCon -> Bool
 --		  unboxed tuples
 isDataTyCon tc@(AlgTyCon {algTcRhs = rhs})  
   = case rhs of
-        OpenDataTyCon -> True
+        OpenTyCon {}  -> not (otIsNewtype rhs)
 	DataTyCon {}  -> True
-	OpenNewTyCon  -> False
 	NewTyCon {}   -> False
-	AbstractTyCon -> False	-- We don't know, so return False
+	AbstractTyCon -> False	 -- We don't know, so return False
 isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity
 isDataTyCon other = False
 
 isNewTyCon :: TyCon -> Bool
-isNewTyCon (AlgTyCon {algTcRhs = rhs}) = case rhs of
-					   OpenNewTyCon -> True
-					   NewTyCon {}  -> True
-					   _	        -> False
-isNewTyCon other			= False
+isNewTyCon (AlgTyCon {algTcRhs = rhs}) = 
+  case rhs of
+    OpenTyCon {} -> otIsNewtype rhs
+    NewTyCon {}  -> True
+    _	         -> False
+isNewTyCon other		       = False
 
 -- This is an important refinement as typical newtype optimisations do *not*
 -- hold for newtype families.  Why?  Given a type `T a', if T is a newtype
@@ -616,22 +620,24 @@ isEnumerationTyCon (AlgTyCon {algTcRhs = DataTyCon { is_enum = res }}) = res
 isEnumerationTyCon other				       	       = False
 
 isOpenTyCon :: TyCon -> Bool
-isOpenTyCon (SynTyCon {synTcRhs = OpenSynTyCon _}) = True
-isOpenTyCon (AlgTyCon {algTcRhs = OpenDataTyCon }) = True
-isOpenTyCon (AlgTyCon {algTcRhs = OpenNewTyCon  }) = True
-isOpenTyCon _					   = False
+isOpenTyCon (SynTyCon {synTcRhs = OpenSynTyCon _ _}) = True
+isOpenTyCon (AlgTyCon {algTcRhs = OpenTyCon {}    }) = True
+isOpenTyCon _					     = False
 
 assocTyConArgPoss_maybe :: TyCon -> Maybe [Int]
-assocTyConArgPoss_maybe (AlgTyCon { tyConArgPoss = poss }) = poss
-assocTyConArgPoss_maybe (SynTyCon { tyConArgPoss = poss }) = poss
-assocTyConArgPoss_maybe _                                  = Nothing
+assocTyConArgPoss_maybe (AlgTyCon { 
+			   algTcRhs = OpenTyCon {otArgPoss = poss}})  = poss
+assocTyConArgPoss_maybe (SynTyCon { synTcRhs = OpenSynTyCon _ poss }) = poss
+assocTyConArgPoss_maybe _ = Nothing
 
 isTyConAssoc :: TyCon -> Bool
 isTyConAssoc = isJust . assocTyConArgPoss_maybe
 
 setTyConArgPoss :: TyCon -> [Int] -> TyCon
-setTyConArgPoss tc@(AlgTyCon {}) poss = tc { tyConArgPoss = Just poss }
-setTyConArgPoss tc@(SynTyCon {}) poss = tc { tyConArgPoss = Just poss }
+setTyConArgPoss tc@(AlgTyCon { algTcRhs = rhs })               poss = 
+  tc { algTcRhs = rhs {otArgPoss = Just poss} }
+setTyConArgPoss tc@(SynTyCon { synTcRhs = OpenSynTyCon ki _ }) poss = 
+  tc { synTcRhs = OpenSynTyCon ki (Just poss) }
 setTyConArgPoss tc _ = pprPanic "setTyConArgPoss" (ppr tc)
 
 isTupleTyCon :: TyCon -> Bool
@@ -769,7 +775,7 @@ tyConFamilySize  :: TyCon -> Int
 tyConFamilySize (AlgTyCon   {algTcRhs = DataTyCon {data_cons = cons}}) = 
   length cons
 tyConFamilySize (AlgTyCon   {algTcRhs = NewTyCon {}})                  = 1
-tyConFamilySize (AlgTyCon   {algTcRhs = OpenDataTyCon})                = 0
+tyConFamilySize (AlgTyCon   {algTcRhs = OpenTyCon {}})                 = 0
 tyConFamilySize (TupleTyCon {})	 		                       = 1
 #ifdef DEBUG
 tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other)
@@ -826,7 +832,7 @@ synTyConType tc = case synTcRhs tc of
 		    _		   -> pprPanic "synTyConType" (ppr tc)
 
 synTyConResKind :: TyCon -> Kind
-synTyConResKind (SynTyCon {synTcRhs = OpenSynTyCon kind}) = kind
+synTyConResKind (SynTyCon {synTcRhs = OpenSynTyCon kind _}) = kind
 synTyConResKind tycon  = pprPanic "synTyConResKind" (ppr tycon)
 \end{code}