[project @ 2005-01-27 10:44:00 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index bd0e95c..395744d 100644 (file)
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -4,7 +4,7 @@
 \section[TcBinds]{TcBinds}
 
 \begin{code}
-module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds, tcSpecSigs ) where
+module TcBinds ( tcBindsAndThen, tcTopBinds, tcHsBootSigs, tcMonoBinds, tcSpecSigs ) where
 
 #include "HsVersions.h"
 
@@ -13,7 +13,8 @@ import {-# SOURCE #-} TcExpr  ( tcCheckSigma, tcCheckRho )
 
 import CmdLineOpts     ( DynFlag(Opt_MonomorphismRestriction) )
 import HsSyn           ( HsExpr(..), HsBind(..), LHsBinds, Sig(..),
-                         LSig, Match(..), HsBindGroup(..), IPBind(..),
+                         LSig, Match(..), HsBindGroup(..), IPBind(..), 
+                         HsType(..), hsLTyVarNames, isVanillaLSig,
                          LPat, GRHSs, MatchGroup(..), emptyLHsBinds, isEmptyLHsBinds,
                          collectHsBindBinders, collectPatBinders, pprPatBind
                        )
@@ -21,7 +22,7 @@ import TcHsSyn                ( TcId, TcDictBinds, zonkId, mkHsLet )
 
 import TcRnMonad
 import Inst            ( InstOrigin(..), newDictsAtLoc, newIPDict, instToId )
-import TcEnv           ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv, newLocalName, tcLookupLocalIds )
+import TcEnv           ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv2, newLocalName, tcLookupLocalIds )
 import TcUnify         ( Expected(..), tcInfer, checkSigTyVars, sigCtxt )
 import TcSimplify      ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, 
                          tcSimplifyToDicts, tcSimplifyIPs )
@@ -30,7 +31,7 @@ import TcHsType               ( tcHsSigType, UserTypeCtxt(..), tcAddLetBoundTyVars,
                        )
 import TcPat           ( tcPat, PatCtxt(..) )
 import TcSimplify      ( bindInstsOfLocalFuns )
-import TcMType         ( newTyFlexiVarTy, tcSkolSigType, zonkQuantifiedTyVar, zonkTcTypes )
+import TcMType         ( newTyFlexiVarTy, tcSkolType, zonkQuantifiedTyVar, zonkTcTypes )
 import TcType          ( TcTyVar, SkolemInfo(SigSkol), 
                          TcTauType, TcSigmaType, 
                          TvSubstEnv, mkTvSubst, substTheta, substTy, 
@@ -94,15 +95,28 @@ tcTopBinds :: [HsBindGroup Name] -> TcM (LHsBinds TcId, TcLclEnv)
        --       want.  The bit we care about is the local bindings
        --       and the free type variables thereof
 tcTopBinds binds
-  = tc_binds_and_then TopLevel glue binds      $
-    getLclEnv                                  `thenM` \ env ->
-    returnM (emptyLHsBinds, env)
+  = tc_binds_and_then TopLevel glue binds $
+           do  { env <- getLclEnv
+               ; return (emptyLHsBinds, env) }
   where
        -- The top level bindings are flattened into a giant 
        -- implicitly-mutually-recursive MonoBinds
     glue (HsBindGroup binds1 _ _) (binds2, env) = (binds1 `unionBags` binds2, env)
+    glue (HsIPBinds _)                   _             = panic "Top-level HsIpBinds"
        -- Can't have a HsIPBinds at top level
 
+tcHsBootSigs :: [HsBindGroup Name] -> TcM (LHsBinds TcId, TcLclEnv)
+-- A hs-boot file has only one BindGroup, and it only has type
+-- signatures in it.  The renamer checked all this
+tcHsBootSigs [HsBindGroup _ sigs _]
+  = do { ids <- mapM (addLocM tc_sig) (filter isVanillaLSig sigs)
+       ; tcExtendIdEnv ids $ do 
+       { env <- getLclEnv
+       ; return (emptyLHsBinds, env) }}
+  where
+    tc_sig (Sig (L _ name) ty)
+      = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
+          ; return (mkLocalId name sigma_ty) }
 
 tcBindsAndThen
        :: (HsBindGroup TcId -> thing -> thing)         -- Combinator
@@ -242,7 +256,7 @@ tcBindWithSigs      :: TopLevelFlag
 tcBindWithSigs top_lvl mbind sigs is_rec = do  
   {    -- TYPECHECK THE SIGNATURES
     tc_ty_sigs <- recoverM (returnM []) $
-                 tcTySigs [sig | sig@(L _(Sig name _)) <- sigs]
+                 tcTySigs (filter isVanillaLSig sigs)
   ; let lookup_sig = lookupSig tc_ty_sigs
 
        -- SET UP THE MAIN RECOVERY; take advantage of any type sigs
@@ -442,10 +456,12 @@ tcMonoBinds binds lookup_sig is_rec
        -- though each type sig should scope only over its own RHS,
        -- because the renamer has sorted all that out.
        ; let mono_info  = getMonoBindInfo tc_binds
-             rhs_tvs    = [ tv | (_, Just sig, _) <- mono_info, tv <- sig_tvs sig ]
+             rhs_tvs    = [ (name, mkTyVarTy tv)
+                          | (_, Just sig, _) <- mono_info, 
+                            (name, tv) <- sig_scoped sig `zip` sig_tvs sig ]
              rhs_id_env = map mk mono_info     -- A binding for each term variable
 
-       ; binds' <- tcExtendTyVarEnv rhs_tvs    $
+       ; binds' <- tcExtendTyVarEnv2 rhs_tvs   $
                    tcExtendIdEnv2   rhs_id_env $
                    mapBagM (wrapLocM tcRhs) tc_binds
        ; return (binds', mono_info) }
@@ -562,10 +578,18 @@ tcTySig (L span (Sig (L _ name) ty))
     do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
        ; let rigid_info = SigSkol name
              poly_id    = mkLocalId name sigma_ty
-       ; (tvs, theta, tau) <- tcSkolSigType rigid_info sigma_ty
+
+               -- The scoped names are the ones explicitly mentioned
+               -- in the HsForAll.  (There may be more in sigma_ty, because
+               -- of nested type synonyms.  See Note [Scoped] with TcSigInfo.)
+             scoped_names = case ty of
+                               L _ (HsForAllTy _ tvs _ _) -> hsLTyVarNames tvs
+                               other                      -> []
+
+       ; (tvs, theta, tau) <- tcSkolType rigid_info sigma_ty
        ; loc <- getInstLoc (SigOrigin rigid_info)
-       ; return (TcSigInfo { sig_id = poly_id, sig_tvs = tvs, 
-                             sig_theta = theta, sig_tau = tau, 
+       ; return (TcSigInfo { sig_id = poly_id, sig_scoped = scoped_names,
+                             sig_tvs = tvs, sig_theta = theta, sig_tau = tau, 
                              sig_loc = loc }) }
 
 checkSigCtxt :: TcSigInfo -> TcSigInfo -> TcM TcSigInfo