Straightened out implicit coercions for indexed types

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

diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index 5ded0a8..723a790 100644 (file)
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -14,10 +14,12 @@ module TyCon(
        SynTyConRhs(..),
 
        isFunTyCon, isUnLiftedTyCon, isProductTyCon, 
-       isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
+       isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isClosedNewTyCon,
+       isPrimTyCon, 
        isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon,
+       assocTyConArgPoss_maybe, isTyConAssoc, setTyConArgPoss,
        isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
-       isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo,
+       isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo_maybe,
        isHiBootTyCon, isSuperKindTyCon,
         isCoercionTyCon_maybe, isCoercionTyCon,
 
@@ -48,6 +50,7 @@ module TyCon(
        tyConArity,
        isClassTyCon, tyConClass_maybe,
        isFamInstTyCon, tyConFamInst_maybe, tyConFamilyCoercion_maybe,
+       tyConFamInstIndex,
        synTyConDefn, synTyConRhs, synTyConType, synTyConResKind,
        tyConExtName,           -- External name for foreign types
 
@@ -67,6 +70,7 @@ import Class          ( Class )
 import BasicTypes      ( Arity, RecFlag(..), Boxity(..), isBoxed )
 import Name            ( Name, nameUnique, NamedThing(getName) )
 import PrelNames       ( Unique, Uniquable(..) )
+import Maybe           ( isJust )
 import Maybes          ( orElse )
 import Outputable
 import FastString
@@ -94,11 +98,19 @@ data TyCon
        tyConName   :: Name,
        tyConKind   :: Kind,
        tyConArity  :: Arity,
-       
+
        tyConTyVars :: [TyVar],         -- Scopes over (a) the algTcStupidTheta
                                        --             (b) the cached types in
                                        --                 algTyConRhs.NewTyCon
                                        -- 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.
+       
        algTcSelIds :: [Id],            -- Its record selectors (empty if none)
 
        algTcGadtSyntax  :: Bool,       -- True <=> the data type was declared using GADT syntax
@@ -133,13 +145,21 @@ data TyCon
     }
 
   | 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
@@ -255,6 +275,9 @@ data AlgTyConParent = -- An ordinary type constructor has no parent.
                                    TyCon       -- a *coercion* identifying
                                                -- the representation type
                                                -- with the type instance
+                                    Int         -- index to generate unique
+                                               -- name (needed here to put
+                                               -- into iface)
 
 data SynTyConRhs
   = OpenSynTyCon Kind  -- Type family: *result* kind given
@@ -399,6 +422,7 @@ 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,
@@ -468,6 +492,7 @@ mkSynTyCon name kind tyvars rhs
        tyConKind = kind,
        tyConArity = length tyvars,
        tyConTyVars = tyvars,
+       tyConArgPoss = Nothing,
        synTcRhs = rhs
     }
 
@@ -530,13 +555,23 @@ isDataTyCon tc@(AlgTyCon {algTcRhs = rhs})
        OpenNewTyCon  -> False
        NewTyCon {}   -> False
        AbstractTyCon -> pprPanic "isDataTyCon" (ppr tc)
-
 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
@@ -573,6 +608,19 @@ isOpenTyCon (AlgTyCon {algTcRhs = OpenDataTyCon }) = True
 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
@@ -712,9 +760,9 @@ newTyConRep :: TyCon -> ([TyVar], Type)
 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
@@ -769,20 +817,25 @@ tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas}) = Just clas
 tyConClass_maybe ther_tycon                                = Nothing
 
 isFamInstTyCon :: TyCon -> Bool
-isFamInstTyCon (AlgTyCon {algTcParent = FamilyTyCon _ _ _}) = True
-isFamInstTyCon other_tycon                                 = False
+isFamInstTyCon (AlgTyCon {algTcParent = FamilyTyCon _ _ _ _}) = True
+isFamInstTyCon other_tycon                                   = False
 
 tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type])
-tyConFamInst_maybe (AlgTyCon {algTcParent = FamilyTyCon fam instTys _}) = 
+tyConFamInst_maybe (AlgTyCon {algTcParent = FamilyTyCon fam instTys _ _}) = 
   Just (fam, instTys)
-tyConFamInst_maybe ther_tycon                                          = 
+tyConFamInst_maybe ther_tycon                                            = 
   Nothing
 
 tyConFamilyCoercion_maybe :: TyCon -> Maybe TyCon
-tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = FamilyTyCon _ _ coe}) = 
+tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = FamilyTyCon _ _ coe _}) = 
   Just coe
-tyConFamilyCoercion_maybe ther_tycon                                    = 
+tyConFamilyCoercion_maybe ther_tycon                                      = 
   Nothing
+
+tyConFamInstIndex :: TyCon -> Int
+tyConFamInstIndex (AlgTyCon {algTcParent = FamilyTyCon _ _ _ index}) = index
+tyConFamInstIndex _                                                 = 
+  panic "tyConFamInstIndex"
 \end{code}