Moved argument position info of ATs into tycon rhs info

diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index 864cb19..aa01e70 100644 (file)
--- a/compiler/iface/BuildTyCl.lhs
+++ b/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

diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index e491039..a02f449 100644 (file)
--- a/compiler/iface/MkIface.lhs
+++ b/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

diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 1643e19..5af949e 100644 (file)
--- a/compiler/iface/TcIface.lhs
+++ b/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))
      }

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 0474581..6788eee 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/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_` 

diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index 6dba52b..8b2b24c 100644 (file)
--- a/compiler/types/TyCon.lhs
+++ b/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}