Indexed newtypes

Mon Sep 18 19:24:27 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Indexed newtypes
  Thu Aug 31 22:09:21 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * Indexed newtypes
    - This patch makes indexed newtypes work
    - Only lightly tested
    - We need to distinguish between open and closed newtypes in a number of
      places, because looking through newtypes doesn't work easily for open ones.

diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index aa87958..3de9905 100644 (file)
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -38,7 +38,8 @@ import Type           ( Type, ThetaType,
 import Coercion                ( isEqPred, mkEqPred )
 import TyCon           ( TyCon, FieldLabel, tyConDataCons, 
                          isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon,
-                          isNewTyCon, isRecursiveTyCon, tyConFamInst_maybe )
+                          isNewTyCon, isClosedNewTyCon, isRecursiveTyCon,
+                          tyConFamInst_maybe )
 import Class           ( Class, classTyCon )
 import Name            ( Name, NamedThing(..), nameUnique, mkSysTvName, mkSystemName )
 import Var             ( TyVar, CoVar, Id, mkTyVar, tyVarKind, setVarUnique,
@@ -727,9 +728,10 @@ splitProductType str ty
 deepSplitProductType_maybe ty
   = do { (res@(tycon, tycon_args, _, _)) <- splitProductType_maybe ty
        ; let {result 
-             | isNewTyCon tycon && not (isRecursiveTyCon tycon)
+             | isClosedNewTyCon tycon && not (isRecursiveTyCon tycon)
              = deepSplitProductType_maybe (newTyConInstRhs tycon tycon_args)
-             | isNewTyCon tycon = Nothing  -- cannot unbox through recursive newtypes
+             | isNewTyCon tycon = Nothing  -- cannot unbox through recursive
+                                          -- newtypes nor through families
              | otherwise = Just res}
        ; result
        }

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 0ad0bc6..fda6763 100644 (file)
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -394,6 +394,15 @@ wrapFamInstBody tycon args result_expr
   | otherwise
   = result_expr
 
+-- Apply the coercion in the opposite direction.
+--
+unwrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
+unwrapFamInstBody tycon args result_expr
+  | Just co_con <- tyConFamilyCoercion_maybe tycon
+  = mkCoerce (mkTyConApp co_con args) result_expr
+  | otherwise
+  = result_expr
+
 \end{code}
 
 
@@ -842,12 +851,25 @@ wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 -- If a coercion constructor is prodivided in the newtype, then we use
 -- it, otherwise the wrap/unwrap are both no-ops 
 --
+-- If the we are dealing with a newtype instance, we have a second coercion
+-- identifying the family instance with the constructor of the newtype
+-- instance.  This coercion is applied in any case (ie, composed with the
+-- coercion constructor of the newtype or applied by itself).
+--
 wrapNewTypeBody tycon args result_expr
-  | Just co_con <- newTyConCo tycon
-  = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr
-  | otherwise
-  = result_expr
+  = wrapFamInstBody tycon args inner
+  where
+    inner
+      | Just co_con <- newTyConCo tycon
+      = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr
+      | otherwise
+      = result_expr
 
+-- When unwrapping, we do *not* apply any family coercion, because this will
+-- be done via a CoPat by the type checker.  We have to do it this way as
+-- computing the right type arguments for the coercion requires more than just
+-- a spliting operation (cf, TcPat.tcConPat).
+--
 unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 unwrapNewTypeBody tycon args result_expr
   | Just co_con <- newTyConCo tycon

diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs
index e7d79e6..246bfa0 100644 (file)
--- a/compiler/coreSyn/MkExternalCore.lhs
+++ b/compiler/coreSyn/MkExternalCore.lhs
@@ -69,7 +69,7 @@ collect_tdefs tcon tdefs
 --         | null (tyConDataCons tcon) = error "MkExternalCore died: can't handle datatype declarations with no data constructors"
          | otherwise = 
                 C.Data (make_con_qid (tyConName tcon)) (map make_tbind tyvars) (map make_cdef (tyConDataCons tcon)) 
-         where repclause | isRecursiveTyCon tcon = Nothing
+         where repclause | isRecursiveTyCon tcon || isOpenTyCon tcon= Nothing
                         | otherwise = Just (make_ty rep)
                                            where (_, rep) = newTyConRep tcon
     tyvars = tyConTyVars tcon

diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 4f44eb2..8c5a743 100644 (file)
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -312,7 +312,7 @@ mkCoAlgCaseMatchResult var ty match_alts
     arg_id1    = head arg_ids1
     var_ty      = idType var
     (tc, ty_args) = splitNewTyConApp var_ty
-    newtype_rhs = unwrapNewTypeBody tycon ty_args (Var var)
+    newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
                
        -- Stuff for data types
     data_cons      = tyConDataCons tycon

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index ebe4083..32402b2 100644 (file)
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -51,7 +51,7 @@ import Type           ( Type, splitFunTys, dropForAlls, isStrictType,
 import Coercion         ( isEqPredTy
                        )
 import Coercion         ( Coercion, mkUnsafeCoercion, coercionKind )
-import TyCon           ( tyConDataCons_maybe, isNewTyCon )
+import TyCon           ( tyConDataCons_maybe, isClosedNewTyCon )
 import DataCon         ( DataCon, dataConRepArity, dataConExTyVars, 
                           dataConInstArgTys, dataConTyCon )
 import VarSet
@@ -1467,7 +1467,7 @@ mkCase1 scrut case_bndr ty alts   -- Identity case
     identity_alt (con, args, rhs) = de_note rhs `cheapEqExpr` identity_rhs con args
 
     identity_rhs (DataAlt con) args
-      | isNewTyCon (dataConTyCon con) 
+      | isClosedNewTyCon (dataConTyCon con) 
       = wrapNewTypeBody (dataConTyCon con) arg_tys (varToCoreExpr $ head args)
       | otherwise
       = mkConApp con (arg_ty_exprs ++ varsToCoreExprs args)

diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index f165e2e..0f923ff 100644 (file)
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -47,7 +47,7 @@ import TysWiredIn     ( boolTy, parrTyCon, tupleTyCon )
 import Type            ( Type, mkTyConApp, substTys, substTheta )
 import StaticFlags     ( opt_IrrefutableTuples )
 import TyCon           ( TyCon, FieldLabel, tyConFamInst_maybe,
-                         tyConFamilyCoercion_maybe, tyConTyVars )
+                         tyConFamilyCoercion_maybe, tyConTyVars, isNewTyCon )
 import DataCon         ( DataCon, dataConTyCon, dataConFullSig, dataConName,
                          dataConFieldLabels, dataConSourceArity, 
                          dataConStupidTheta, dataConUnivTyVars )
@@ -586,6 +586,7 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
     -- representation tycon.
     --
     boxySplitTyConAppWithFamily tycon pat_ty =
+      traceTc traceMsg >>
       case tyConFamInst_maybe tycon of
         Nothing                   -> boxySplitTyConApp tycon pat_ty
        Just (fam_tycon, instTys) -> 
@@ -594,6 +595,12 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
             ; boxyUnifyList (substTys subst instTys) scrutinee_arg_tys
             ; return freshTvs
             }
+      where
+        traceMsg = sep [ text "tcConPat:boxySplitTyConAppWithFamily:" <+>
+                        ppr tycon <+> ppr pat_ty
+                      , text "  family instance:" <+> 
+                        ppr (tyConFamInst_maybe tycon)
+                       ]
 
     -- Wraps the pattern (which must be a ConPatOut pattern) in a coercion
     -- pattern if the tycon is an instance of a family.
@@ -601,6 +608,8 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
     unwrapFamInstScrutinee :: TyCon -> [Type] -> Pat Id -> Pat Id
     unwrapFamInstScrutinee tycon args pat
       | Just co_con <- tyConFamilyCoercion_maybe tycon 
+--      , not (isNewTyCon tycon)       -- newtypes are explicitly unwrapped by
+                                    -- the desugarer
           -- NB: We can use CoPat directly, rather than mkCoPat, as we know the
           --    coercion is not the identity; mkCoPat is inconvenient as it
           --    wants a located pattern.

diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index fb91a0d..ff49a6e 100644 (file)
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -40,7 +40,7 @@ import Type     ( Type, Kind, PredType, substTyWith, mkAppTy, mkForAllTy,
                     coreEqType, splitAppTys, isTyVarTy, splitTyConApp_maybe,
                     tyVarsOfType, mkTyVarTys
                   )
-import TyCon      ( TyCon, tyConArity, mkCoercionTyCon, isNewTyCon,
+import TyCon      ( TyCon, tyConArity, mkCoercionTyCon, isClosedNewTyCon,
                     newTyConRhs, newTyConCo, 
                     isCoercionTyCon, isCoercionTyCon_maybe )
 import Var       ( Var, TyVar, isTyVar, tyVarKind )
@@ -451,7 +451,7 @@ splitNewTypeRepCo_maybe :: Type -> Maybe (Type, Coercion)
 splitNewTypeRepCo_maybe ty 
   | Just ty' <- coreView ty = splitNewTypeRepCo_maybe ty'
 splitNewTypeRepCo_maybe (TyConApp tc tys)
-  | isNewTyCon tc 
+  | isClosedNewTyCon tc 
   = ASSERT( tys `lengthIs` tyConArity tc )     -- splitNewTypeRepCo_maybe only be applied 
                                                 --     to *types* (of kind *)
         case newTyConRhs tc of

diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index d536f59..1464fab 100644 (file)
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -14,7 +14,8 @@ 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,
@@ -560,6 +561,14 @@ isNewTyCon (AlgTyCon {algTcRhs = rhs}) = case rhs of
                                           _            -> 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
 --     has *one* constructor, 

diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index b7f1a00..e872d6a 100644 (file)
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -117,8 +117,8 @@ import PrelNames( openTypeKindTyConKey, unliftedTypeKindTyConKey,
                   ubxTupleKindTyConKey, argTypeKindTyConKey )
 import TyCon   ( TyCon, isRecursiveTyCon, isPrimTyCon,
                  isUnboxedTupleTyCon, isUnLiftedTyCon,
-                 isFunTyCon, isNewTyCon, isOpenTyCon, newTyConRep,
-                 newTyConRhs, 
+                 isFunTyCon, isNewTyCon, isClosedNewTyCon, isOpenTyCon,
+                 newTyConRep, newTyConRhs, 
                  isAlgTyCon, tyConArity, isSuperKindTyCon,
                  tcExpandTyCon_maybe, coreExpandTyCon_maybe,
                  tyConKind, PrimRep(..), tyConPrimRep, tyConUnique,
@@ -458,8 +458,7 @@ repType :: Type -> Type
 repType ty | Just ty' <- coreView ty = repType ty'
 repType (ForAllTy _ ty)  = repType ty
 repType (TyConApp tc tys)
-  | isNewTyCon tc &&
-    not (isOpenTyCon tc) = -- Recursive newtypes are opaque to coreView
+  | isClosedNewTyCon tc  = -- Recursive newtypes are opaque to coreView
                           -- but we must expand them here.  Sure to
                           -- be saturated because repType is only applied
                           -- to types of kind *
@@ -618,7 +617,7 @@ splitRecNewType_maybe :: Type -> Maybe Type
 -- Only applied to types of kind *, hence the newtype is always saturated
 splitRecNewType_maybe ty | Just ty' <- coreView ty = splitRecNewType_maybe ty'
 splitRecNewType_maybe (TyConApp tc tys)
-  | isNewTyCon tc
+  | isClosedNewTyCon tc
   = ASSERT( tys `lengthIs` tyConArity tc )     -- splitRecNewType_maybe only be applied 
                                                --      to *types* (of kind *)
     ASSERT( isRecursiveTyCon tc )              -- Guaranteed by coreView