Improve pretty-printing of Core

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

diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index cb85028..43f9411 100644 (file)
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -22,7 +22,7 @@ module Coercion (
         mkSymCoercion, mkTransCoercion,
         mkLeftCoercion, mkRightCoercion, mkInstCoercion, mkAppCoercion,
         mkForAllCoercion, mkFunCoercion, mkInstsCoercion, mkUnsafeCoercion,
-        mkNewTypeCoercion, mkAppsCoercion,
+        mkNewTypeCoercion, mkDataInstCoercion, mkAppsCoercion,
 
         splitNewTypeRepCo_maybe, decomposeCo,
 
@@ -39,8 +39,8 @@ import Type     ( Type, Kind, PredType, substTyWith, mkAppTy, mkForAllTy,
                     kindView, mkTyConApp, isCoercionKind, isEqPred, mkAppTys,
                     coreEqType, splitAppTys, isTyVarTy, splitTyConApp_maybe
                   )
-import TyCon      ( TyCon, tyConArity, mkCoercionTyCon, isNewTyCon,
-                    newTyConRhs, newTyConCo, 
+import TyCon      ( TyCon, tyConArity, mkCoercionTyCon, isClosedNewTyCon,
+                    newTyConRhs, newTyConCo_maybe, 
                     isCoercionTyCon, isCoercionTyCon_maybe )
 import Var       ( Var, TyVar, isTyVar, tyVarKind )
 import Name       ( BuiltInSyntax(..), Name, mkWiredInName, tcName )
@@ -277,27 +277,48 @@ splitRightCoercion_maybe (TyConApp tc [co])
 splitRightCoercion_maybe other = Nothing
 
 -- Unsafe coercion is not safe, it is used when we know we are dealing with
--- bottom, which is the one case in which it is safe.  It is also used to 
+-- bottom, which is one case in which it is safe.  It is also used to 
 -- implement the unsafeCoerce# primitive.
 mkUnsafeCoercion :: Type -> Type -> Coercion
 mkUnsafeCoercion ty1 ty2 
   = mkCoercion unsafeCoercionTyCon [ty1, ty2]
 
 
--- Make the coercion associated with a newtype.  If we have
---
---   newtype T a b = MkT (Int, a, b)
---
--- Then (mkNewTypeCoercion CoT T [a,b] (Int, a, b)) creates the coercion
--- CoT, such kinding rule such that
+-- See note [Newtype coercions] in TyCon
+mkNewTypeCoercion :: Name -> TyCon -> ([TyVar], Type) -> TyCon
+mkNewTypeCoercion name tycon (tvs, rhs_ty)
+  = mkCoercionTyCon name co_con_arity (mkKindingFun rule)
+  where
+    co_con_arity = length tvs
+
+    rule args = (TyConApp tycon tys, substTyWith tvs tys rhs_ty, rest)
+        where
+          tys  = take co_con_arity args
+          rest = drop co_con_arity args
+
+-- Coercion identifying a data/newtype representation type and its family
+-- instance.  It has the form `Co tvs :: F ts :=: R tvs', where `Co' is the
+-- coercion tycon built here, `F' the family tycon and `R' the (derived)
+-- representation tycon.
 --
---   CoT S U :: (Int, S, U) :=: T S U
-mkNewTypeCoercion :: Name -> TyCon -> [TyVar] -> Type -> TyCon
-mkNewTypeCoercion name tycon tvs rhs_ty 
-  = ASSERT (length tvs == tyConArity tycon)
-    mkCoercionTyCon name (tyConArity tycon) rule
+mkDataInstCoercion :: Name     -- unique name for the coercion tycon
+                  -> [TyVar]   -- type parameters of the coercion (`tvs')
+                  -> TyCon     -- family tycon (`F')
+                  -> [Type]    -- type instance (`ts')
+                  -> TyCon     -- representation tycon (`R')
+                  -> TyCon     -- => coercion tycon (`Co')
+mkDataInstCoercion name tvs family instTys rep_tycon
+  = mkCoercionTyCon name coArity (mkKindingFun rule)
   where
-    rule args = mkCoKind (substTyWith tvs args rhs_ty) (TyConApp tycon args)
+    coArity = length tvs
+
+    rule args = (substTyWith tvs tys $              -- with sigma = [tys/tvs],
+                  TyConApp family instTys,          --       sigma (F ts)
+                TyConApp rep_tycon tys,             --   :=: R tys
+                rest)                               -- surplus arguments
+      where
+        tys  = take coArity args
+        rest = drop coArity args
 
 --------------------------------------
 -- Coercion Type Constructors...
@@ -310,7 +331,8 @@ mkNewTypeCoercion name tycon tvs rhs_ty
 -- then ((sym c) (sym d) (sym e)) :: (p1 p2 p3)=(q1 q2 q3)
 --
 -- (mkKindingFun f) is given the args [c, sym d, sym e]
-mkKindingFun :: ([Type] -> (Type, Type, [Type])) -> [Type] -> Kind
+mkKindingFun :: ([Type] -> (Type, Type, [Type]))
+            -> [Type] -> Kind
 mkKindingFun f args = 
   let (ty1, ty2, rest) = f args in 
   let (argtys1, argtys2) = unzip (map coercionKind rest) in
@@ -402,7 +424,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
@@ -410,6 +432,6 @@ splitNewTypeRepCo_maybe (TyConApp tc tys)
               ASSERT( length tvs == length tys )
              Just (substTyWith tvs tys rep_ty, mkTyConApp co_con tys)
   where
-    co_con = maybe (pprPanic "splitNewTypeRepCo_maybe" (ppr tc)) id (newTyConCo tc)
+    co_con = maybe (pprPanic "splitNewTypeRepCo_maybe" (ppr tc)) id (newTyConCo_maybe tc)
 splitNewTypeRepCo_maybe other = Nothing
 \end{code}