Extended TyCon and friends to represent family declarations

[ghc-hetmet.git] / compiler / iface / BuildTyCl.lhs

diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index ad58028..c669daf 100644 (file)
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -6,7 +6,8 @@
 module BuildTyCl (
        buildSynTyCon, buildAlgTyCon, buildDataCon,
        buildClass,
-       mkAbstractTyConRhs, mkNewTyConRhs, mkDataTyConRhs
+       mkAbstractTyConRhs, mkOpenDataTyConRhs, mkOpenNewTyConRhs,
+       mkNewTyConRhs, mkDataTyConRhs 
     ) where
 
 #include "HsVersions.h"
@@ -26,14 +27,16 @@ import OccName              ( mkDataConWrapperOcc, mkDataConWorkerOcc, mkClassTyConOcc,
                          mkClassDataConOcc, mkSuperDictSelOcc, mkNewTyCoOcc )
 import MkId            ( mkDataConIds, mkRecordSelId, mkDictSelId )
 import Class           ( mkClass, Class( classTyCon), FunDep, DefMeth(..) )
-import TyCon           ( mkSynTyCon, mkAlgTyCon, visibleDataCons, tyConStupidTheta,
-                         tyConDataCons, isNewTyCon, mkClassTyCon, TyCon( tyConTyVars ),
-                         isRecursiveTyCon, tyConArity,
-                         AlgTyConRhs(..), newTyConRhs )
+import TyCon           ( mkSynTyCon, mkAlgTyCon, visibleDataCons,
+                         tyConStupidTheta, tyConDataCons, isNewTyCon,
+                         mkClassTyCon, TyCon( tyConTyVars ),
+                         isRecursiveTyCon, tyConArity, AlgTyConRhs(..),
+                         SynTyConRhs(..), newTyConRhs )
 import Type            ( mkArrowKinds, liftedTypeKind, typeKind, 
                          tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
-                         splitTyConApp_maybe, splitAppTy_maybe, getTyVar_maybe,
-                         mkPredTys, mkTyVarTys, ThetaType, Type, 
+                         splitTyConApp_maybe, splitAppTy_maybe,
+                         getTyVar_maybe, 
+                         mkPredTys, mkTyVarTys, ThetaType, Type, Kind,
                          substTyWith, zipTopTvSubst, substTheta, mkForAllTys,
                           mkTyConApp, mkTyVarTy )
 import Coercion         ( mkNewTypeCoercion )
@@ -45,8 +48,13 @@ import List          ( nub )
 
 \begin{code}
 ------------------------------------------------------
-buildSynTyCon name tvs rhs_ty
-  = mkSynTyCon name kind tvs rhs_ty
+buildSynTyCon :: Name -> [TyVar] -> SynTyConRhs -> TyCon
+buildSynTyCon name tvs rhs@(OpenSynTyCon rhs_ki)
+  = mkSynTyCon name kind tvs rhs
+  where
+    kind = mkArrowKinds (map tyVarKind tvs) rhs_ki
+buildSynTyCon name tvs rhs@(SynonymTyCon rhs_ty)
+  = mkSynTyCon name kind tvs rhs
   where
     kind = mkArrowKinds (map tyVarKind tvs) (typeKind rhs_ty)
 
@@ -72,6 +80,12 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
 mkAbstractTyConRhs :: AlgTyConRhs
 mkAbstractTyConRhs = AbstractTyCon
 
+mkOpenDataTyConRhs :: AlgTyConRhs
+mkOpenDataTyConRhs = OpenDataTyCon
+
+mkOpenNewTyConRhs :: AlgTyConRhs
+mkOpenNewTyConRhs = OpenNewTyCon
+
 mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
 mkDataTyConRhs cons
   = DataTyCon { data_cons = cons, is_enum = all isNullarySrcDataCon cons }
@@ -82,15 +96,24 @@ mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
 -- because the latter is part of a knot, whereas the former is not.
 mkNewTyConRhs tycon_name tycon con 
   = do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
-       ; let co_tycon = mkNewTypeCoercion co_tycon_name tycon tvs rhs_ty 
+       ; let co_tycon = mkNewTypeCoercion co_tycon_name tycon tvs rhs_ty
+              cocon_maybe 
+                | all_coercions || isRecursiveTyCon tycon 
+                = Just co_tycon
+                | otherwise              
+                = Nothing
        ; return (NewTyCon { data_con = con, 
-                            nt_co = Just co_tycon, 
+                            nt_co = cocon_maybe, 
                              -- Coreview looks through newtypes with a Nothing
                              -- for nt_co, or uses explicit coercions otherwise
                             nt_rhs = rhs_ty,
                             nt_etad_rhs = eta_reduce tvs rhs_ty,
                             nt_rep = mkNewTyConRep tycon rhs_ty }) }
   where
+        -- if all_coercions is True then we use coercions for all newtypes
+        -- otherwise we use coercions for recursive newtypes and look through
+        -- non-recursive newtypes
+    all_coercions = True
     tvs    = tyConTyVars tycon
     rhs_ty = head (dataConInstOrigArgTys con (mkTyVarTys tvs))
        -- Instantiate the data con with the 
@@ -138,7 +161,7 @@ mkNewTyConRep tc rhs_ty
                     if isRecursiveTyCon tc then
                        go (tc:tcs) (substTyWith tvs tys rhs_ty)
                     else
-                        go tcs (head tys)
+                        substTyWith tvs tys rhs_ty
                where
                  (tvs, rhs_ty) = newTyConRhs tc