[project @ 1999-07-16 09:36:07 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index 0e15147..bb63100 100644 (file)
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -19,7 +19,7 @@ import TcMonoType     ( tcHsType, tcHsTypeKind,
 import TcEnv           ( ValueEnv, tcExtendTyVarEnv, 
                          tcExtendGlobalValEnv, tcSetValueEnv,
                          tcLookupTyConByKey, tcLookupValueMaybe,
-                         explicitLookupValue, badCon, badPrimOp
+                         explicitLookupValue, badCon, badPrimOp, valueEnvIds
                        )
 import TcType          ( TcKind, kindToTcKind )
 
@@ -39,10 +39,10 @@ import Id           ( Id, mkId, mkVanillaId,
                        )
 import IdInfo
 import DataCon         ( dataConSig, dataConArgTys )
-import Type            ( mkSynTy, mkTyVarTys, splitAlgTyConApp )
+import Type            ( mkSynTy, mkTyVarTys, splitAlgTyConApp, unUsgTy )
 import Var             ( IdOrTyVar, mkTyVar, tyVarKind )
 import VarEnv
-import Name            ( Name, NamedThing(..) )
+import Name            ( Name, NamedThing(..), isLocallyDefined )
 import Unique          ( rationalTyConKey )
 import TysWiredIn      ( integerTy, stringTy )
 import Demand          ( wwLazy )
@@ -65,23 +65,23 @@ tcInterfaceSigs :: ValueEnv         -- Envt to use when checking unfoldings
                -> TcM s [Id]
                
 
-tcInterfaceSigs unf_env (SigD (IfaceSig name ty id_infos src_loc) : rest)
-  = tcAddSrcLoc src_loc (
-    tcAddErrCtxt (ifaceSigCtxt name) (
-       tcHsType ty                                             `thenTc` \ sigma_ty ->
-       tcIdInfo unf_env name sigma_ty vanillaIdInfo id_infos   `thenTc` \ id_info ->
+tcInterfaceSigs unf_env decls
+  = listTc [ do_one name ty id_infos src_loc
+          | SigD (IfaceSig name ty id_infos src_loc) <- decls]
+  where
+    in_scope_vars = filter isLocallyDefined (valueEnvIds unf_env)
+
+    do_one name ty id_infos src_loc
+      = tcAddSrcLoc src_loc                            $       
+       tcAddErrCtxt (ifaceSigCtxt name)                $
+       tcHsType ty                                     `thenTc` \ sigma_ty ->
+       tcIdInfo unf_env in_scope_vars name 
+                sigma_ty vanillaIdInfo id_infos        `thenTc` \ id_info ->
        returnTc (mkId name sigma_ty id_info)
-    ))                                         `thenTc` \ sig_id ->
-    tcInterfaceSigs unf_env rest               `thenTc` \ sig_ids ->
-    returnTc (sig_id : sig_ids)
-
-tcInterfaceSigs unf_env (other_decl : rest) = tcInterfaceSigs unf_env rest
-
-tcInterfaceSigs unf_env [] = returnTc []
 \end{code}
 
 \begin{code}
-tcIdInfo unf_env name ty info info_ins
+tcIdInfo unf_env in_scope_vars name ty info info_ins
   = foldlTc tcPrag vanillaIdInfo info_ins
   where
     tcPrag info (HsArity arity) = returnTc (info `setArityInfo`  arity)
@@ -91,7 +91,7 @@ tcIdInfo unf_env name ty info info_ins
 
     tcPrag info (HsUnfold inline_prag maybe_expr)
        = (case maybe_expr of
-               Just expr -> tcPragExpr unf_env name [] expr
+               Just expr -> tcPragExpr unf_env name in_scope_vars expr
                Nothing   -> returnNF_Tc Nothing
          )                                     `thenNF_Tc` \ maybe_expr' ->
          let
@@ -114,7 +114,7 @@ tcIdInfo unf_env name ty info info_ins
 
 \begin{code}
 tcWorkerInfo unf_env ty info worker_name
-  | arity == 0
+  | not (hasArity arity_info)
   = pprPanic "Worker with no arity info" (ppr worker_name)
  
   | otherwise
@@ -131,9 +131,10 @@ tcWorkerInfo unf_env ty info worker_name
   where
        -- We are relying here on arity, cpr and strictness info always appearing 
        -- before worker info,  fingers crossed ....
-      arity    = arityLowerBound (arityInfo info)
-      cpr_info = cprInfo info
-      demands  = case strictnessInfo info of
+      arity_info = arityInfo info
+      arity      = arityLowerBound arity_info
+      cpr_info   = cprInfo info
+      demands    = case strictnessInfo info of
                        StrictnessInfo d _ -> d
                        _                  -> repeat wwLazy     -- Noncommittal
 \end{code}
@@ -212,7 +213,7 @@ tcCoreExpr (UfTuple name args)
     mapTc tcCoreExpr args      `thenTc` \ args' ->
     let
        -- Put the missing type arguments back in
-       con_args = map (Type . coreExprType) args' ++ args'
+       con_args = map (Type . unUsgTy . coreExprType) args' ++ args'
     in
     returnTc (Con con con_args)
 
@@ -254,7 +255,8 @@ tcCoreExpr (UfNote note expr)
   = tcCoreExpr expr            `thenTc` \ expr' ->
     case note of
        UfCoerce to_ty -> tcHsType to_ty        `thenTc` \ to_ty' ->
-                         returnTc (Note (Coerce to_ty' (coreExprType expr')) expr')
+                         returnTc (Note (Coerce (unUsgTy to_ty')
+                                                 (unUsgTy (coreExprType expr'))) expr')
        UfInlineCall   -> returnTc (Note InlineCall expr')
        UfInlineMe     -> returnTc (Note InlineMe   expr')
        UfSCC cc       -> returnTc (Note (SCC cc)   expr')