[project @ 2000-12-07 08:28:05 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 ed543f6..a606b16 100644 (file)
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -8,7 +8,7 @@ module TcIfaceSig ( tcInterfaceSigs, tcVar, tcCoreExpr, tcCoreLamBndrs ) where
 
 #include "HsVersions.h"
 
-import HsSyn           ( HsDecl(..), TyClDecl(..), HsTupCon(..) )
+import HsSyn           ( TyClDecl(..), HsTupCon(..) )
 import TcMonad
 import TcMonoType      ( tcHsType )
                                -- NB: all the tyars in interface files are kinded,
@@ -17,10 +17,10 @@ import TcMonoType   ( tcHsType )
 
 import TcEnv           ( TcEnv, RecTcEnv, tcExtendTyVarEnv, 
                          tcExtendGlobalValEnv, tcSetEnv,
-                         tcLookupGlobal_maybe, tcLookupRecId, tcEnvIds
+                         tcLookupGlobal_maybe, tcLookupRecId_maybe
                        )
 
-import RnHsSyn         ( RenamedHsDecl )
+import RnHsSyn         ( RenamedTyClDecl )
 import HsCore
 import Literal         ( Literal(..) )
 import CoreSyn
@@ -32,10 +32,11 @@ import WorkWrap             ( mkWrapper )
 import Id              ( Id, mkId, mkVanillaId, isDataConWrapId_maybe )
 import MkId            ( mkCCallOpId )
 import IdInfo
-import DataCon         ( dataConSig, dataConArgTys )
-import Type            ( mkTyVarTys, splitAlgTyConApp_maybe, unUsgTy )
+import DataCon         ( DataCon, dataConId, dataConSig, dataConArgTys )
+import Type            ( mkTyVarTys, splitAlgTyConApp_maybe )
+import TysWiredIn      ( tupleCon )
 import Var             ( mkTyVar, tyVarKind )
-import Name            ( Name, isLocallyDefined )
+import Name            ( Name )
 import Demand          ( wwLazy )
 import ErrUtils                ( pprBagOfErrors )
 import Outputable      
@@ -52,30 +53,28 @@ signatures.
 
 \begin{code}
 tcInterfaceSigs :: RecTcEnv            -- Envt to use when checking unfoldings
-               -> [RenamedHsDecl]      -- Ignore non-sig-decls in these decls
+               -> [RenamedTyClDecl]    -- Ignore non-sig-decls in these decls
                -> TcM [Id]
                
 
 tcInterfaceSigs unf_env decls
   = listTc [ do_one name ty id_infos src_loc
-          | TyClD (IfaceSig name ty id_infos src_loc) <- decls]
+          | IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc =src_loc} <- decls]
   where
     in_scope_vars = [] -- I think this will be OK
-                       -- If so, don't pass it around
-                       -- Was: filter isLocallyDefined (tcEnvIds 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 ->
+                sigma_ty id_infos                      `thenTc` \ id_info ->
        returnTc (mkId name sigma_ty id_info)
 \end{code}
 
 \begin{code}
-tcIdInfo unf_env in_scope_vars name ty info info_ins
-  = foldlTc tcPrag vanillaIdInfo info_ins
+tcIdInfo unf_env in_scope_vars name ty info_ins
+  = foldlTc tcPrag constantIdInfo info_ins
   where
     tcPrag info (HsArity arity) = returnTc (info `setArityInfo`  arity)
     tcPrag info (HsNoCafRefs)   = returnTc (info `setCafInfo`   NoCafRefs)
@@ -110,7 +109,7 @@ tcWorkerInfo unf_env ty info worker_name
   = uniqSMToTcM (mkWrapper ty arity demands res_bot cpr_info) `thenNF_Tc` \ wrap_fn ->
     let
        -- Watch out! We can't pull on unf_env too eagerly!
-       info' = case tcLookupRecId unf_env worker_name of
+       info' = case tcLookupRecId_maybe unf_env worker_name of
                  Just worker_id -> info `setUnfoldingInfo`  mkTopUnfolding (wrap_fn worker_id)
                                          `setWorkerInfo`     HasWorker worker_id arity
 
@@ -207,14 +206,16 @@ tcCoreExpr (UfCCall cc ty)
     tcGetUnique                `thenNF_Tc` \ u ->
     returnTc (Var (mkCCallOpId u cc ty'))
 
-tcCoreExpr (UfTuple (HsTupCon name _) args) 
-  = tcVar name                 `thenTc` \ con_id ->
-    mapTc tcCoreExpr args      `thenTc` \ args' ->
+tcCoreExpr (UfTuple (HsTupCon _ boxity arity) args) 
+  = mapTc tcCoreExpr args      `thenTc` \ args' ->
     let
        -- Put the missing type arguments back in
-       con_args = map (Type . unUsgTy . exprType) args' ++ args'
+       con_args = map (Type . exprType) args' ++ args'
     in
     returnTc (mkApps (Var con_id) con_args)
+  where
+    con_id = dataConId (tupleCon boxity arity)
+    
 
 tcCoreExpr (UfLam bndr body)
   = tcCoreLamBndr bndr                 $ \ bndr' ->
@@ -254,8 +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 (unUsgTy to_ty')
-                                                 (unUsgTy (exprType expr'))) expr')
+                         returnTc (Note (Coerce to_ty'
+                                                 (exprType expr')) expr')
        UfInlineCall   -> returnTc (Note InlineCall expr')
        UfInlineMe     -> returnTc (Note InlineMe   expr')
        UfSCC cc       -> returnTc (Note (SCC cc)   expr')
@@ -322,13 +323,9 @@ tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs)
 -- A case alternative is made quite a bit more complicated
 -- by the fact that we omit type annotations because we can
 -- work them out.  True enough, but its not that easy!
-tcCoreAlt scrut_ty alt@(UfDataAlt con_name, names, rhs)
-  = tcVar con_name             `thenTc` \ con_id ->
+tcCoreAlt scrut_ty alt@(con, names, rhs)
+  = tcConAlt con       `thenTc` \ con ->
     let
-       con = case isDataConWrapId_maybe con_id of
-               Just con -> con
-               Nothing  -> pprPanic "tcCoreAlt" (ppr con_id)
-
        (main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con
 
        (_, inst_tys, cons) = case splitAlgTyConApp_maybe scrut_ty of
@@ -341,7 +338,7 @@ tcCoreAlt scrut_ty alt@(UfDataAlt con_name, names, rhs)
        arg_ids
 #ifdef DEBUG
                | length id_names /= length arg_tys
-               = pprPanic "tcCoreAlts" (ppr (con_name, names, rhs) $$
+               = pprPanic "tcCoreAlts" (ppr (con, names, rhs) $$
                                         (ppr main_tyvars <+> ppr ex_tyvars) $$
                                         ppr arg_tys)
                | otherwise
@@ -353,6 +350,17 @@ tcCoreAlt scrut_ty alt@(UfDataAlt con_name, names, rhs)
     tcExtendGlobalValEnv arg_ids               $
     tcCoreExpr rhs                                     `thenTc` \ rhs' ->
     returnTc (DataAlt con, ex_tyvars' ++ arg_ids, rhs')
+
+
+tcConAlt :: UfConAlt Name -> TcM DataCon
+tcConAlt (UfTupleAlt (HsTupCon _ boxity arity))
+  = returnTc (tupleCon boxity arity)
+
+tcConAlt (UfDataAlt con_name)
+  = tcVar con_name     `thenTc` \ con_id ->
+    returnTc (case isDataConWrapId_maybe con_id of
+                   Just con -> con
+                   Nothing  -> pprPanic "tcCoreAlt" (ppr con_id))
 \end{code}
 
 \begin{code}