[project @ 2002-03-14 15:27:15 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcHsSyn.lhs

diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 2c8ce25..2d01c49 100644 (file)
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -48,13 +48,13 @@ import TcEnv        ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, TcEnv, TcId )
 
 import TcMonad
 import Type      ( Type )
-import TcType    ( TcType )
-import TcMType   ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars )
+import TcType    ( TcType, tcGetTyVar )
+import TcMType   ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcTyVars )
 import TysPrim   ( charPrimTy, intPrimTy, floatPrimTy,
                    doublePrimTy, addrPrimTy
                  )
 import TysWiredIn ( charTy, stringTy, intTy, integerTy,
-                   mkListTy, mkTupleTy, unitTy )
+                   mkListTy, mkPArrTy, mkTupleTy, unitTy )
 import CoreSyn    ( Expr )
 import Var       ( isId )
 import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName )
@@ -161,6 +161,7 @@ outPatType (LazyPat pat)    = outPatType pat
 outPatType (AsPat var pat)     = idType var
 outPatType (ConPat _ ty _ _ _) = ty
 outPatType (ListPat ty _)      = mkListTy ty
+outPatType (PArrPat ty _)      = mkPArrTy ty
 outPatType (TuplePat pats box) = mkTupleTy box (length pats) (map outPatType pats)
 outPatType (RecPat _ ty _ _ _)  = ty
 outPatType (SigPat _ ty _)     = ty
@@ -190,6 +191,7 @@ collectTypedPatBinders (AsPat a pat)               = a : collectTypedPatBinders pat
 collectTypedPatBinders (SigPat pat _ _)               = collectTypedPatBinders pat
 collectTypedPatBinders (ConPat _ _ _ _ pats)   = concat (map collectTypedPatBinders pats)
 collectTypedPatBinders (ListPat t pats)        = concat (map collectTypedPatBinders pats)
+collectTypedPatBinders (PArrPat t pats)        = concat (map collectTypedPatBinders pats)
 collectTypedPatBinders (TuplePat pats _)       = concat (map collectTypedPatBinders pats)
 collectTypedPatBinders (RecPat _ _ _ _ fields) = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat)
                                                          fields)
@@ -350,9 +352,12 @@ zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
                 new_globals)
   where
     zonkExport (tyvars, global, local)
-       = zonkTcSigTyVars tyvars        `thenNF_Tc` \ new_tyvars ->
+       = zonkTcTyVars tyvars           `thenNF_Tc` \ tys ->
+         let
+               new_tyvars = map (tcGetTyVar "zonkExport") tys
                -- This isn't the binding occurrence of these tyvars
-               -- but they should *be* tyvars.  Hence zonkTcSigTyVars.
+               -- but they should *be* tyvars.  Hence tcGetTyVar.
+         in
          zonkIdBndr global             `thenNF_Tc` \ new_global ->
          zonkIdOcc local               `thenNF_Tc` \ new_local -> 
          returnNF_Tc (new_tyvars, new_global, new_local)
@@ -493,6 +498,11 @@ zonkExpr (ExplicitList ty exprs)
     mapNF_Tc zonkExpr exprs    `thenNF_Tc` \ new_exprs ->
     returnNF_Tc (ExplicitList new_ty new_exprs)
 
+zonkExpr (ExplicitPArr ty exprs)
+  = zonkTcTypeToType ty                `thenNF_Tc` \ new_ty ->
+    mapNF_Tc zonkExpr exprs    `thenNF_Tc` \ new_exprs ->
+    returnNF_Tc (ExplicitPArr new_ty new_exprs)
+
 zonkExpr (ExplicitTuple exprs boxed)
   = mapNF_Tc zonkExpr exprs    `thenNF_Tc` \ new_exprs ->
     returnNF_Tc (ExplicitTuple new_exprs boxed)
@@ -514,12 +524,18 @@ zonkExpr (RecordUpdOut expr in_ty out_ty dicts rbinds)
 
 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
 zonkExpr (ArithSeqIn _)      = panic "zonkExpr:ArithSeqIn"
+zonkExpr (PArrSeqIn _)       = panic "zonkExpr:PArrSeqIn"
 
 zonkExpr (ArithSeqOut expr info)
   = zonkExpr expr      `thenNF_Tc` \ new_expr ->
     zonkArithSeq info  `thenNF_Tc` \ new_info ->
     returnNF_Tc (ArithSeqOut new_expr new_info)
 
+zonkExpr (PArrSeqOut expr info)
+  = zonkExpr expr      `thenNF_Tc` \ new_expr ->
+    zonkArithSeq info  `thenNF_Tc` \ new_info ->
+    returnNF_Tc (PArrSeqOut new_expr new_info)
+
 zonkExpr (HsCCall fun args may_gc is_casm result_ty)
   = mapNF_Tc zonkExpr args     `thenNF_Tc` \ new_args ->
     zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
@@ -667,12 +683,17 @@ zonkPat (ListPat ty pats)
     zonkPats pats              `thenNF_Tc` \ (new_pats, ids) ->
     returnNF_Tc (ListPat new_ty new_pats, ids)
 
+zonkPat (PArrPat ty pats)
+  = zonkTcTypeToType ty        `thenNF_Tc` \ new_ty ->
+    zonkPats pats              `thenNF_Tc` \ (new_pats, ids) ->
+    returnNF_Tc (PArrPat new_ty new_pats, ids)
+
 zonkPat (TuplePat pats boxed)
   = zonkPats pats              `thenNF_Tc` \ (new_pats, ids) ->
     returnNF_Tc (TuplePat new_pats boxed, ids)
 
 zonkPat (ConPat n ty tvs dicts pats)
-  = zonkTcTypeToType ty                `thenNF_Tc` \ new_ty ->
+  = zonkTcTypeToType ty                        `thenNF_Tc` \ new_ty ->
     mapNF_Tc zonkTcTyVarToTyVar tvs    `thenNF_Tc` \ new_tvs ->
     mapNF_Tc zonkIdBndr dicts          `thenNF_Tc` \ new_dicts ->
     tcExtendGlobalValEnv new_dicts     $