Fix scoped type variables for expression type signatures

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

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 0ad0bc6..3f24a85 100644 (file)
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -47,9 +47,10 @@ import TysPrim               ( openAlphaTyVars, alphaTyVar, alphaTy,
 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 HsBinds          ( HsWrapper(..), isIdHsWrapper )
 import Coercion         ( mkSymCoercion, mkUnsafeCoercion, isEqPred )
 import TcType          ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, 
                          mkTyConApp, mkTyVarTys, mkClassPred, isPredTy,
@@ -60,11 +61,12 @@ import TcType               ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy,
 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,
                           tyConFamInst_maybe, tyConFamilyCoercion_maybe,
-                          newTyConCo )
+                          newTyConCo_maybe )
 import Class           ( Class, classTyCon, classSelIds )
 import Var             ( Id, TyVar, Var, setIdType )
 import VarSet          ( isEmptyVarSet, subVarSet, varSetElems )
@@ -95,7 +97,6 @@ import NewDemand      ( mkStrictSig, DmdResult(..),
 import DmdAnal         ( dmdAnalTopRhs )
 import CoreSyn
 import Unique          ( mkBuiltinUnique, mkPrimOpIdUnique )
-import Maybe           ( fromJust )
 import Maybes
 import PrelNames
 import Util             ( dropList, isSingleton )
@@ -220,14 +221,14 @@ This coercion is conditionally applied by wrapFamInstBody.
 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
 
-  | otherwise                                  -- Algebraic, no wrapper
+  | otherwise                               -- Algebraic, no wrapper
   = DCIds Nothing wrk_id
   where
     (univ_tvs, ex_tvs, eq_spec, 
@@ -240,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
+    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
@@ -248,7 +255,9 @@ mkDataConIds wrap_name wkr_name data_con
                         -- 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 
@@ -394,6 +403,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}
 
 
@@ -621,8 +639,8 @@ mkRecordSelId tycon field_label
                -- and apply to (Maybe b'), to get (Maybe b)
 
         rhs = case co_fn of
-               ExprCoFn co -> Cast (Var the_arg_id) co
-               id_co       -> ASSERT(isIdCoercion id_co) Var the_arg_id
+               WpCo co -> Cast (Var the_arg_id) co
+               id_co       -> ASSERT(isIdHsWrapper id_co) Var the_arg_id
 
        field_vs    = filter (not . isPredTy . idType) arg_vs 
        the_arg_id  = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` field_vs) field_label
@@ -842,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 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_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
-  | Just co_con <- newTyConCo tycon
+  | Just co_con <- newTyConCo_maybe tycon
   = mkCoerce (mkTyConApp co_con args) result_expr
   | otherwise
   = result_expr