Extend TyCons and DataCons to represent data instance decls

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

diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 94e0dcb..388d040 100644 (file)
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -19,8 +19,10 @@ import IfaceEnv              ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder,
                          extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName,
                          tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc, 
                          newIfaceName, newIfaceNames, ifaceExportNames )
-import BuildTyCl       ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass,
-                         mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
+import BuildTyCl       ( buildSynTyCon, buildAlgTyCon, buildDataCon,
+                         buildClass, 
+                         mkAbstractTyConRhs, mkOpenDataTyConRhs,
+                         mkOpenNewTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
 import TcRnMonad
 import Type            ( liftedTypeKind, splitTyConApp, mkTyConApp,
                           liftedTypeKindTyCon, unliftedTypeKindTyCon, 
@@ -28,14 +30,15 @@ import Type         ( liftedTypeKind, splitTyConApp, mkTyConApp,
                           ubxTupleKindTyCon,
                          mkTyVarTys, ThetaType )
 import TypeRep         ( Type(..), PredType(..) )
-import TyCon           ( TyCon, tyConName )
+import TyCon           ( TyCon, tyConName, SynTyConRhs(..), 
+                         AlgTyConParent(..) )
 import HscTypes                ( ExternalPackageState(..), 
                          TyThing(..), tyThingClass, tyThingTyCon, 
                          ModIface(..), ModDetails(..), HomeModInfo(..),
                          emptyModDetails, lookupTypeEnv, lookupType, typeEnvIds )
 import InstEnv         ( Instance(..), mkImportedInstance )
 import CoreSyn
-import CoreUtils       ( exprType, dataConInstPat )
+import CoreUtils       ( exprType, dataConRepFSInstPat )
 import CoreUnfold
 import CoreLint                ( lintUnfolding )
 import WorkWrap                ( mkWrapper )
@@ -53,7 +56,8 @@ import Var            ( TyVar, mkTyVar, tyVarKind )
 import Name            ( Name, nameModule, nameIsLocalOrFrom, isWiredInName,
                          nameOccName, wiredInNameTyThing_maybe )
 import NameEnv
-import OccName         ( OccName, mkVarOccFS, mkTyVarOccoccNameSpace, pprNameSpace  )
+import OccName         ( OccName, mkVarOccFS, mkTyVarOcc, occNameSpace, 
+                         pprNameSpace, occNameFS  )
 import FastString       ( FastString )
 import Module          ( Module, moduleName )
 import UniqFM          ( lookupUFM )
@@ -65,6 +69,7 @@ import SrcLoc         ( noSrcLoc )
 import Util            ( zipWithEqual, equalLength, splitAtList )
 import DynFlags                ( DynFlag(..), isOneShot )
 
+import Monad           ( liftM )
 \end{code}
 
 This module takes
@@ -355,26 +360,35 @@ tcIfaceDecl (IfaceData {ifName = occ_name,
                        ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
                        ifCons = rdr_cons, 
                        ifRec = is_rec, 
-                       ifGeneric = want_generic })
+                       ifGeneric = want_generic,
+                       ifFamily = mb_family })
   = do { tc_name <- lookupIfaceTop occ_name
        ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
 
        { tycon <- fixM ( \ tycon -> do
            { stupid_theta <- tcIfaceCtxt ctxt
-           ; cons  <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
+           ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
+           ; family <- case mb_family of
+                         Nothing  -> return Nothing
+                         Just fam -> 
+                           do { famTyCon <- tcIfaceTyCon fam
+                              ; return $ Just famTyCon
+                              }
            ; buildAlgTyCon tc_name tyvars stupid_theta
-                           cons is_rec want_generic gadt_syn
+                           cons is_rec want_generic gadt_syn family
            })
         ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
        ; return (ATyCon tycon)
     }}
 
 tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, 
-                      ifSynRhs = rdr_rhs_ty})
+                      ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty})
    = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
      { tc_name <- lookupIfaceTop occ_name
-     ; rhs_ty <- tcIfaceType rdr_rhs_ty
-     ; return (ATyCon (buildSynTyCon tc_name tyvars rhs_ty))
+     ; rhs_tyki <- tcIfaceType rdr_rhs_ty
+     ; let rhs = if isOpen then OpenSynTyCon rhs_tyki 
+                          else SynonymTyCon rhs_tyki
+     ; return (ATyCon (buildSynTyCon tc_name tyvars rhs))
      }
 
 tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs, 
@@ -412,6 +426,8 @@ tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
 tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
   = case if_cons of
        IfAbstractTyCon  -> return mkAbstractTyConRhs
+       IfOpenDataTyCon  -> return mkOpenDataTyConRhs
+       IfOpenNewTyCon   -> return mkOpenNewTyConRhs
        IfDataTyCon cons -> do  { data_cons <- mappM tc_con_decl cons
                                ; return (mkDataTyConRhs data_cons) }
        IfNewTyCon con   -> do  { data_con <- tc_con_decl con
@@ -421,7 +437,7 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
                         ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
                         ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
                         ifConArgTys = args, ifConFields = field_lbls,
-                        ifConStricts = stricts})
+                        ifConStricts = stricts, ifConInstTys = mb_insttys })
       = bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do
        bindIfaceTyVars ex_tvs   $ \ ex_tyvars -> do
        { name  <- lookupIfaceTop occ
@@ -440,19 +456,24 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
        -- the component types unless they are really needed
        ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args)
        ; lbl_names <- mappM lookupIfaceTop field_lbls
+       ; mb_insttys' <- case mb_insttys of 
+                          Nothing      -> return Nothing 
+                          Just insttys -> liftM Just $ 
+                                            mappM tcIfaceType insttys
 
        ; buildDataCon name is_infix {- Not infix -}
                       stricts lbl_names
                       univ_tyvars ex_tyvars 
                        eq_spec theta 
                       arg_tys tycon
+                      mb_insttys'
        }
     mk_doc con_name = ptext SLIT("Constructor") <+> ppr con_name
 
 tcIfaceEqSpec spec
   = mapM do_item spec
   where
-    do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ
+    do_item (occ, if_ty) = do { tv <- tcIfaceTyVar (occNameFS occ)
                               ; ty <- tcIfaceType if_ty
                               ; return (tv,ty) }
 \end{code}     
@@ -680,13 +701,14 @@ tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs)
 tcIfaceDataAlt con inst_tys arg_strs rhs
   = do { us <- newUniqueSupply
        ; let uniqs = uniqsFromSupply us
-       ; let   (ex_tvs, co_tvs, arg_ids) = dataConInstPat uniqs con inst_tys
-                all_tvs                   = ex_tvs ++ co_tvs
+       ; let (ex_tvs, co_tvs, arg_ids)
+                     = dataConRepFSInstPat arg_strs uniqs con inst_tys
+              all_tvs = ex_tvs ++ co_tvs
 
        ; rhs' <- extendIfaceTyVarEnv all_tvs   $
                  extendIfaceIdEnv arg_ids      $
                  tcIfaceExpr rhs
-       ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }
+       ; return (DataAlt con, all_tvs ++ arg_ids, rhs') }
 \end{code}
 
 
@@ -967,7 +989,5 @@ mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
 mk_iface_tyvar name ifKind = do { kind <- tcIfaceType ifKind
                                 ; return (mkTyVar name kind)
                                 }
-
-mk_iface_tyvar name kind = mkTyVar name kind
 \end{code}