Improve pretty-printing of Core

[ghc-hetmet.git] / compiler / basicTypes / MkId.lhs

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index d306128..41460e1 100644 (file)
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -47,7 +47,8 @@ import TysPrim                ( openAlphaTyVars, alphaTyVar, alphaTy,
 import TysWiredIn      ( charTy, mkListTy )
 import PrelRules       ( primOpRules )
 import Type            ( TyThing(..), mkForAllTy, tyVarsOfTypes, 
 import TysWiredIn      ( charTy, mkListTy )
 import PrelRules       ( primOpRules )
 import Type            ( TyThing(..), mkForAllTy, tyVarsOfTypes, 

-                         newTyConInstRhs, mkTopTvSubst, substTyVar, substTy )
+                         newTyConInstRhs, mkTopTvSubst, substTyVar, 
+                         substTys, zipTopTvSubst )

 import TcGadt           ( gadtRefine, refineType, emptyRefinement )
 import HsBinds          ( ExprCoFn(..), isIdCoercion )
 import Coercion         ( mkSymCoercion, mkUnsafeCoercion, isEqPred )
 import TcGadt           ( gadtRefine, refineType, emptyRefinement )
 import HsBinds          ( ExprCoFn(..), isIdCoercion )
 import Coercion         ( mkSymCoercion, mkUnsafeCoercion, isEqPred )

@@ -60,10 +61,12 @@ import TcType               ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy,
 import CoreUtils       ( exprType, dataConOrigInstPat, mkCoerce )
 import CoreUnfold      ( mkTopUnfolding, mkCompulsoryUnfolding )
 import Literal         ( nullAddrLit, mkStringLit )
 import CoreUtils       ( exprType, dataConOrigInstPat, mkCoerce )
 import CoreUnfold      ( mkTopUnfolding, mkCompulsoryUnfolding )
 import Literal         ( nullAddrLit, mkStringLit )

-import TyCon           ( TyCon, isNewTyCon, tyConDataCons, FieldLabel,
+import TyCon           ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
+                         FieldLabel,

                           tyConStupidTheta, isProductTyCon, isDataTyCon,
                           isRecursiveTyCon, isFamInstTyCon,
                           tyConStupidTheta, isProductTyCon, isDataTyCon,
                           isRecursiveTyCon, isFamInstTyCon,

-                          tyConFamInst_maybe, newTyConCo ) 
+                          tyConFamInst_maybe, tyConFamilyCoercion_maybe,
+                          newTyConCo_maybe )

 import Class           ( Class, classTyCon, classSelIds )
 import Var             ( Id, TyVar, Var, setIdType )
 import VarSet          ( isEmptyVarSet, subVarSet, varSetElems )
 import Class           ( Class, classTyCon, classSelIds )
 import Var             ( Id, TyVar, Var, setIdType )
 import VarSet          ( isEmptyVarSet, subVarSet, varSetElems )

@@ -94,7 +97,6 @@ import NewDemand      ( mkStrictSig, DmdResult(..),
 import DmdAnal         ( dmdAnalTopRhs )
 import CoreSyn
 import Unique          ( mkBuiltinUnique, mkPrimOpIdUnique )
 import DmdAnal         ( dmdAnalTopRhs )
 import CoreSyn
 import Unique          ( mkBuiltinUnique, mkPrimOpIdUnique )

-import Maybe           ( fromJust )

 import Maybes
 import PrelNames
 import Util             ( dropList, isSingleton )
 import Maybes
 import PrelNames
 import Util             ( dropList, isSingleton )

@@ -190,22 +192,43 @@ Notice that
   Making an explicit case expression allows the simplifier to eliminate
   it in the (common) case where the constructor arg is already evaluated.
 
   Making an explicit case expression allows the simplifier to eliminate
   it in the (common) case where the constructor arg is already evaluated.
 

+[Wrappers for data instance tycons]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

 In the case of data instances, the wrapper also applies the coercion turning
 the representation type into the family instance type to cast the result of
 In the case of data instances, the wrapper also applies the coercion turning
 the representation type into the family instance type to cast the result of

-the wrapper.
+the wrapper.  For example, consider the declarations
+
+  data family Map k :: * -> *
+  data instance Map (a, b) v = MapPair (Map a (Pair b v))
+
+The tycon to which the datacon MapPair belongs gets a unique internal name of
+the form :R123Map, and we call it the representation tycon.  In contrast, Map
+is the family tycon (accessible via tyConFamInst_maybe).  The wrapper and work
+of MapPair get the types
+
+  $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v
+  $wMapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v
+
+which implies that the wrapper code will have to apply the coercion moving
+between representation and family type.  It is accessible via
+tyConFamilyCoercion_maybe and has kind
+
+  Co123Map a b v :: {Map (a, b) v :=: :R123Map a b v}
+
+This coercion is conditionally applied by wrapFamInstBody.

 
 \begin{code}
 mkDataConIds :: Name -> Name -> DataCon -> DataConIds
 mkDataConIds wrap_name wkr_name data_con
   | isNewTyCon tycon
 
 \begin{code}
 mkDataConIds :: Name -> Name -> DataCon -> DataConIds
 mkDataConIds wrap_name wkr_name data_con
   | isNewTyCon tycon

-  = DCIds Nothing nt_work_id                    -- Newtype, only has a worker
+  = DCIds Nothing nt_work_id                 -- Newtype, only has a worker

 
 

-  | any isMarkedStrict all_strict_marks                -- Algebraic, needs wrapper
-    || not (null eq_spec)
-    || isFamInstTyCon tycon
+  | any isMarkedStrict all_strict_marks             -- Algebraic, needs wrapper
+    || not (null eq_spec)                   -- NB: LoadIface.ifaceDeclSubBndrs
+    || isFamInstTyCon tycon                 --     depends on this test

   = DCIds (Just alg_wrap_id) wrk_id
 
   = DCIds (Just alg_wrap_id) wrk_id
 

-  | otherwise                                  -- Algebraic, no wrapper
+  | otherwise                               -- Algebraic, no wrapper

   = DCIds Nothing wrk_id
   where
     (univ_tvs, ex_tvs, eq_spec, 
   = DCIds Nothing wrk_id
   where
     (univ_tvs, ex_tvs, eq_spec, 

@@ -218,6 +241,12 @@ mkDataConIds wrap_name wkr_name data_con
        -- extra constraints where necessary.
     wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
     subst         = mkTopTvSubst eq_spec
        -- extra constraints where necessary.
     wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
     subst         = mkTopTvSubst eq_spec

+    famSubst      = ASSERT( length (tyConTyVars tycon  ) ==  
+                            length (mkTyVarTys univ_tvs)   )
+                    zipTopTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs)
+                    -- substitution mapping the type constructor's type
+                    -- arguments to the universals of the data constructor
+                    -- (crucial when type checking interfaces)

     dict_tys       = mkPredTys theta
     result_ty_args = map (substTyVar subst) univ_tvs
     result_ty      = case tyConFamInst_maybe tycon of
     dict_tys       = mkPredTys theta
     result_ty_args = map (substTyVar subst) univ_tvs
     result_ty      = case tyConFamInst_maybe tycon of

@@ -226,7 +255,9 @@ mkDataConIds wrap_name wkr_name data_con
                         -- family instance constructor
                       Just (familyTyCon, 
                             instTys)     -> 
                         -- family instance constructor
                       Just (familyTyCon, 
                             instTys)     -> 

-                        mkTyConApp familyTyCon (map (substTy subst) instTys)
+                        mkTyConApp familyTyCon ( substTys subst 
+                                               . substTys famSubst 
+                                               $ instTys)

     wrap_ty        = mkForAllTys wrap_tvs $ mkFunTys dict_tys $
                     mkFunTys orig_arg_tys $ result_ty
        -- NB: watch out here if you allow user-written equality 
     wrap_ty        = mkForAllTys wrap_tvs $ mkFunTys dict_tys $
                     mkFunTys orig_arg_tys $ result_ty
        -- NB: watch out here if you allow user-written equality 

@@ -367,11 +398,20 @@ mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
 --
 wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 wrapFamInstBody tycon args result_expr
 --
 wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 wrapFamInstBody tycon args result_expr

-  | Just (co_con, _) <- tyConFamInst_maybe tycon
+  | Just co_con <- tyConFamilyCoercion_maybe tycon

   = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr
   | otherwise
   = result_expr
 
   = mkCoerce (mkSymCoercion (mkTyConApp co_con 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}
 
 
 \end{code}
 
 

@@ -820,15 +860,28 @@ 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 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
 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_maybe 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
 unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 unwrapNewTypeBody tycon args result_expr

-  | Just co_con <- newTyConCo tycon
+  | Just co_con <- newTyConCo_maybe tycon

   = mkCoerce (mkTyConApp co_con args) result_expr
   | otherwise
   = result_expr
   = mkCoerce (mkTyConApp co_con args) result_expr
   | otherwise
   = result_expr