Big tidy-up of deriving code

[ghc-hetmet.git] / compiler / types / TyCon.lhs

diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index 7fcc52b..9595759 100644 (file)
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -1,7 +1,9 @@
 %
 %

+% (c) The University of Glasgow 2006

 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %

-\section[TyCon]{The @TyCon@ datatype}
+
+The @TyCon@ datatype

 
 \begin{code}
 module TyCon(
 
 \begin{code}
 module TyCon(

@@ -10,16 +12,20 @@ module TyCon(
        PrimRep(..),
        tyConPrimRep,
 
        PrimRep(..),
        tyConPrimRep,
 

-       AlgTyConRhs(..), visibleDataCons, AlgTyConParent(..),
+       AlgTyConRhs(..), visibleDataCons, 
+        AlgTyConParent(..), 

        SynTyConRhs(..),
 
        isFunTyCon, isUnLiftedTyCon, isProductTyCon, 
        SynTyConRhs(..),
 
        isFunTyCon, isUnLiftedTyCon, isProductTyCon, 

-       isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
+       isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isClosedNewTyCon,
+       isPrimTyCon, 

        isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon,
        isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon,

+       assocTyConArgPoss_maybe, isTyConAssoc, setTyConArgPoss,

        isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
        isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,

-       isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo,
+       isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo_maybe,

        isHiBootTyCon, isSuperKindTyCon,
         isCoercionTyCon_maybe, isCoercionTyCon,
        isHiBootTyCon, isSuperKindTyCon,
         isCoercionTyCon_maybe, isCoercionTyCon,

+        isImplicitTyCon,

 
        tcExpandTyCon_maybe, coreExpandTyCon_maybe,
 
 
        tcExpandTyCon_maybe, coreExpandTyCon_maybe,
 

@@ -47,7 +53,7 @@ module TyCon(
        tyConStupidTheta,
        tyConArity,
        isClassTyCon, tyConClass_maybe,
        tyConStupidTheta,
        tyConArity,
        isClassTyCon, tyConClass_maybe,

-       isFamInstTyCon, tyConFamily_maybe,
+       isFamInstTyCon, tyConFamInst_maybe, tyConFamilyCoercion_maybe,

        synTyConDefn, synTyConRhs, synTyConType, synTyConResKind,
        tyConExtName,           -- External name for foreign types
 
        synTyConDefn, synTyConRhs, synTyConType, synTyConResKind,
        tyConExtName,           -- External name for foreign types
 

@@ -59,15 +65,15 @@ module TyCon(
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

-import {-# SOURCE #-} TypeRep ( Kind, Type, Coercion, PredType )
+import {-# SOURCE #-} TypeRep ( Kind, Type, PredType )

 import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon )
 
 import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon )
 

-import Var             ( TyVar, Id )
-import Class           ( Class )
-import BasicTypes      ( Arity, RecFlag(..), Boxity(..), isBoxed )
-import Name            ( Name, nameUnique, NamedThing(getName) )
-import PrelNames       ( Unique, Uniquable(..) )
-import Maybes          ( orElse )
+import Var
+import Class
+import BasicTypes
+import Name
+import PrelNames
+import Maybes

 import Outputable
 import FastString
 \end{code}
 import Outputable
 import FastString
 \end{code}

@@ -94,11 +100,23 @@ data TyCon
        tyConName   :: Name,
        tyConKind   :: Kind,
        tyConArity  :: Arity,
        tyConName   :: Name,
        tyConKind   :: Kind,
        tyConArity  :: Arity,

-       
+

        tyConTyVars :: [TyVar],         -- Scopes over (a) the algTcStupidTheta
                                        --             (b) the cached types in
                                        --                 algTyConRhs.NewTyCon
        tyConTyVars :: [TyVar],         -- Scopes over (a) the algTcStupidTheta
                                        --             (b) the cached types in
                                        --                 algTyConRhs.NewTyCon

+                                       --             (c) the family instance
+                                       --                 types if present

                                        -- But not over the data constructors
                                        -- 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
        algTcSelIds :: [Id],            -- Its record selectors (empty if none)
 
        algTcGadtSyntax  :: Bool,       -- True <=> the data type was declared using GADT syntax

@@ -133,13 +151,21 @@ data TyCon
     }
 
   | SynTyCon {
     }
 
   | SynTyCon {

-       tyConUnique :: Unique,
-       tyConName   :: Name,
-       tyConKind   :: Kind,
-       tyConArity  :: Arity,
-
-       tyConTyVars :: [TyVar],         -- Bound tyvars
-       synTcRhs    :: SynTyConRhs      -- Expanded type in here
+       tyConUnique  :: Unique,
+       tyConName    :: Name,
+       tyConKind    :: Kind,
+       tyConArity   :: Arity,
+
+       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

     }
 
   | PrimTyCon {                        -- Primitive types; cannot be defined in Haskell
     }
 
   | PrimTyCon {                        -- Primitive types; cannot be defined in Haskell

@@ -148,7 +174,8 @@ data TyCon
        tyConUnique   :: Unique,
        tyConName     :: Name,
        tyConKind     :: Kind,
        tyConUnique   :: Unique,
        tyConName     :: Name,
        tyConKind     :: Kind,

-       tyConArity    :: Arity,
+       tyConArity    :: Arity,         -- SLPJ Oct06: I'm not sure what the significance
+                                       --             of the arity of a primtycon is!

 
        primTyConRep  :: PrimRep,
                        -- Many primitive tycons are unboxed, but some are
 
        primTyConRep  :: PrimRep,
                        -- Many primitive tycons are unboxed, but some are

@@ -164,8 +191,10 @@ data TyCon
        tyConUnique :: Unique,
         tyConName   :: Name,
        tyConArity  :: Arity,
        tyConUnique :: Unique,
         tyConName   :: Name,
        tyConArity  :: Arity,

-       coKindFun   :: [Type] -> Kind
-    }
+       coKindFun   :: [Type] -> (Type,Type)
+    }          -- INVARAINT: coKindFun is always applied to exactly 'arity' args
+               -- E.g. for trans (c1 :: ta=tb) (c2 :: tb=tc), the coKindFun returns 
+               --      the kind as a pair of types: (ta,tc)

        
   | SuperKindTyCon {    -- Super Kinds, TY (box) and CO (diamond).
                        -- They have no kind; and arity zero
        
   | SuperKindTyCon {    -- Super Kinds, TY (box) and CO (diamond).
                        -- They have no kind; and arity zero

@@ -173,10 +202,6 @@ data TyCon
         tyConName   :: Name
     }
 
         tyConName   :: Name
     }
 

-type KindCon = TyCon
-
-type SuperKindCon = TyCon
-

 type FieldLabel = Name
 
 data AlgTyConRhs
 type FieldLabel = Name
 
 data AlgTyConRhs

@@ -237,9 +262,24 @@ visibleDataCons OpenNewTyCon                     = []
 visibleDataCons (DataTyCon{ data_cons = cs }) = cs
 visibleDataCons (NewTyCon{ data_con = c })    = [c]
 
 visibleDataCons (DataTyCon{ data_cons = cs }) = cs
 visibleDataCons (NewTyCon{ data_con = c })    = [c]
 

-data AlgTyConParent = NoParentTyCon            -- ordinary data type
-                   | ClassTyCon    Class       -- class dictionary
-                   | FamilyTyCon   TyCon       -- instance of type family
+-- Both type classes as well as data/newtype 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.
+--
+data AlgTyConParent = -- An ordinary type constructor has no parent.
+                     NoParentTyCon
+
+                     -- Type constructors representing a class dictionary.
+                   | ClassTyCon    Class       
+
+                     -- Type constructors representing an instances of a type
+                     -- family.
+                   | FamilyTyCon   TyCon       -- the type family
+                                   [Type]      -- instance types
+                                   TyCon       -- a *coercion* identifying
+                                               -- the representation type
+                                               -- with the type instance

 
 data SynTyConRhs
   = OpenSynTyCon Kind  -- Type family: *result* kind given
 
 data SynTyConRhs
   = OpenSynTyCon Kind  -- Type family: *result* kind given

@@ -384,6 +424,7 @@ mkAlgTyCon name kind tyvars stupid rhs sel_ids parent is_rec gen_info gadt_syn
        tyConKind        = kind,
        tyConArity       = length tyvars,
        tyConTyVars      = tyvars,
        tyConKind        = kind,
        tyConArity       = length tyvars,
        tyConTyVars      = tyvars,

+       tyConArgPoss     = Nothing,

        algTcStupidTheta = stupid,
        algTcRhs         = rhs,
        algTcSelIds      = sel_ids,
        algTcStupidTheta = stupid,
        algTcRhs         = rhs,
        algTcSelIds      = sel_ids,

@@ -453,6 +494,7 @@ mkSynTyCon name kind tyvars rhs
        tyConKind = kind,
        tyConArity = length tyvars,
        tyConTyVars = tyvars,
        tyConKind = kind,
        tyConArity = length tyvars,
        tyConTyVars = tyvars,

+       tyConArgPoss = Nothing,

        synTcRhs = rhs
     }
 
        synTcRhs = rhs
     }
 

@@ -501,8 +543,8 @@ isAlgTyCon (TupleTyCon {}) = True
 isAlgTyCon other          = False
 
 isDataTyCon :: TyCon -> Bool
 isAlgTyCon other          = False
 
 isDataTyCon :: TyCon -> Bool

--- isDataTyCon returns True for data types that are represented by
--- heap-allocated constructors.
+-- isDataTyCon returns True for data types that are definitely
+-- represented by heap-allocated constructors.

 -- These are srcutinised by Core-level @case@ expressions, and they
 -- get info tables allocated for them.
 --     True for all @data@ types
 -- These are srcutinised by Core-level @case@ expressions, and they
 -- get info tables allocated for them.
 --     True for all @data@ types

@@ -514,14 +556,24 @@ isDataTyCon tc@(AlgTyCon {algTcRhs = rhs})
        DataTyCon {}  -> True
        OpenNewTyCon  -> False
        NewTyCon {}   -> False
        DataTyCon {}  -> True
        OpenNewTyCon  -> False
        NewTyCon {}   -> False

-       AbstractTyCon -> pprPanic "isDataTyCon" (ppr tc)
-
+       AbstractTyCon -> False  -- We don't know, so return False

 isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity
 isDataTyCon other = False
 
 isNewTyCon :: TyCon -> Bool
 isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity
 isDataTyCon other = False
 
 isNewTyCon :: TyCon -> Bool

-isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True 
-isNewTyCon other                              = False
+isNewTyCon (AlgTyCon {algTcRhs = rhs}) = case rhs of
+                                          OpenNewTyCon -> True
+                                          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
+-- family, there is no unique right hand side by which `T a' can be replaced
+-- by a cast.
+--
+isClosedNewTyCon :: TyCon -> Bool
+isClosedNewTyCon tycon = isNewTyCon tycon && not (isOpenTyCon tycon)

 
 isProductTyCon :: TyCon -> Bool
 -- A "product" tycon
 
 isProductTyCon :: TyCon -> Bool
 -- A "product" tycon

@@ -558,6 +610,19 @@ isOpenTyCon (AlgTyCon {algTcRhs = OpenDataTyCon }) = True
 isOpenTyCon (AlgTyCon {algTcRhs = OpenNewTyCon  }) = True
 isOpenTyCon _                                     = False
 
 isOpenTyCon (AlgTyCon {algTcRhs = OpenNewTyCon  }) = True
 isOpenTyCon _                                     = False
 

+assocTyConArgPoss_maybe :: TyCon -> Maybe [Int]
+assocTyConArgPoss_maybe (AlgTyCon { tyConArgPoss = poss }) = poss
+assocTyConArgPoss_maybe (SynTyCon { tyConArgPoss = 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 _ = pprPanic "setTyConArgPoss" (ppr tc)
+

 isTupleTyCon :: TyCon -> Bool
 -- The unit tycon didn't used to be classed as a tuple tycon
 -- but I thought that was silly so I've undone it
 isTupleTyCon :: TyCon -> Bool
 -- The unit tycon didn't used to be classed as a tuple tycon
 -- but I thought that was silly so I've undone it

@@ -598,13 +663,34 @@ isSuperKindTyCon :: TyCon -> Bool
 isSuperKindTyCon (SuperKindTyCon {}) = True
 isSuperKindTyCon other               = False
 
 isSuperKindTyCon (SuperKindTyCon {}) = True
 isSuperKindTyCon other               = False
 

-isCoercionTyCon_maybe :: TyCon -> Maybe (Arity, [Type] -> Kind)
+isCoercionTyCon_maybe :: TyCon -> Maybe (Arity, [Type] -> (Type,Type))

 isCoercionTyCon_maybe (CoercionTyCon {tyConArity = ar, coKindFun = rule}) 
   = Just (ar, rule)
 isCoercionTyCon_maybe other = Nothing
 
 isCoercionTyCon_maybe (CoercionTyCon {tyConArity = ar, coKindFun = rule}) 
   = Just (ar, rule)
 isCoercionTyCon_maybe other = Nothing
 

+isCoercionTyCon :: TyCon -> Bool

 isCoercionTyCon (CoercionTyCon {}) = True
 isCoercionTyCon other              = False
 isCoercionTyCon (CoercionTyCon {}) = True
 isCoercionTyCon other              = False

+
+-- Identifies implicit tycons that, in particular, do not go into interface
+-- files (because they are implicitly reconstructed when the interface is
+-- read).
+--
+-- Note that 
+--
+-- * associated families are implicit, as they are re-constructed from
+--   the class declaration in which they reside, and 
+-- * family instances are *not* implicit as they represent the instance body
+--   (similar to a dfun does that for a class instance).
+--
+isImplicitTyCon :: TyCon -> Bool
+isImplicitTyCon tycon | isTyConAssoc tycon           = True
+                     | isSynTyCon tycon             = False
+                     | isAlgTyCon tycon             = isClassTyCon tycon ||
+                                                      isTupleTyCon tycon
+isImplicitTyCon _other                               = True
+        -- catches: FunTyCon, PrimTyCon, 
+        -- CoercionTyCon, SuperKindTyCon

 \end{code}
 
 
 \end{code}
 
 

@@ -697,9 +783,9 @@ newTyConRep :: TyCon -> ([TyVar], Type)
 newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rep = rep }}) = (tvs, rep)
 newTyConRep tycon = pprPanic "newTyConRep" (ppr tycon)
 
 newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rep = rep }}) = (tvs, rep)
 newTyConRep tycon = pprPanic "newTyConRep" (ppr tycon)
 

-newTyConCo :: TyCon -> Maybe TyCon
-newTyConCo (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_co = co }}) = co
-newTyConCo tycon = pprPanic "newTyConCo" (ppr tycon)
+newTyConCo_maybe :: TyCon -> Maybe TyCon
+newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = co
+newTyConCo_maybe _                                              = Nothing

 
 tyConPrimRep :: TyCon -> PrimRep
 tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep
 
 tyConPrimRep :: TyCon -> PrimRep
 tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep

@@ -751,15 +837,23 @@ isClassTyCon other_tycon                       = False
 
 tyConClass_maybe :: TyCon -> Maybe Class
 tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas}) = Just clas
 
 tyConClass_maybe :: TyCon -> Maybe Class
 tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas}) = Just clas

-tyConClass_maybe ther_tycon                                = Nothing
+tyConClass_maybe other_tycon                               = Nothing

 
 isFamInstTyCon :: TyCon -> Bool
 
 isFamInstTyCon :: TyCon -> Bool

-isFamInstTyCon (AlgTyCon {algTcParent = FamilyTyCon _}) = True
-isFamInstTyCon other_tycon                             = False
-
-tyConFamily_maybe :: TyCon -> Maybe TyCon
-tyConFamily_maybe (AlgTyCon {algTcParent = FamilyTyCon fam}) = Just fam
-tyConFamily_maybe ther_tycon                                = Nothing
+isFamInstTyCon (AlgTyCon {algTcParent = FamilyTyCon _ _ _ }) = True
+isFamInstTyCon other_tycon                                  = False
+
+tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type])
+tyConFamInst_maybe (AlgTyCon {algTcParent = 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 other_tycon                                   = 
+  Nothing

 \end{code}
 
 
 \end{code}