[project @ 2003-02-05 11:39:26 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 89b7d9b..f134c78 100644 (file)
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -11,23 +11,21 @@ module TcExpr ( tcExpr, tcExpr_id, tcMonoExpr ) where
 #ifdef GHCI    /* Only if bootstrapped */
 import {-# SOURCE #-}  TcSplice( tcSpliceExpr, tcBracket )
 import HsSyn           ( HsReify(..), ReifyFlavour(..) )
-import TcEnv           ( bracketOK, tcMetaTy, tcLookupGlobal,
-                         wellStaged, metaLevel )
+import TcType          ( isTauTy )
+import TcEnv           ( bracketOK, tcMetaTy, checkWellStaged, metaLevel )
 import TcSimplify      ( tcSimplifyBracket )
 import Name            ( isExternalName )
 import qualified DsMeta
 #endif
 
-import HsSyn           ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
-                         mkMonoBind, recBindFields
-                       )
+import HsSyn           ( HsExpr(..), HsLit(..), ArithSeqInfo(..), recBindFields )
 import RnHsSyn         ( RenamedHsExpr, RenamedRecordBinds )
 import TcHsSyn         ( TcExpr, TcRecordBinds, hsLitType, mkHsDictApp, mkHsTyApp, mkHsLet )
 import TcRnMonad
 import TcUnify         ( tcSubExp, tcGen, (<$>),
                          unifyTauTy, unifyFunTy, unifyListTy, unifyPArrTy,
                          unifyTupleTy )
-import BasicTypes      ( RecFlag(..),  isMarkedStrict )
+import BasicTypes      ( isMarkedStrict )
 import Inst            ( InstOrigin(..), 
                          newOverloadedLit, newMethodFromName, newIPDict,
                          newDicts, newMethodWithGivenTy, 
@@ -40,7 +38,6 @@ import TcEnv          ( tcLookupClass, tcLookupGlobal_maybe, tcLookupIdLvl,
 import TcMatches       ( tcMatchesCase, tcMatchLambda, tcDoStmts )
 import TcMonoType      ( tcHsSigType, UserTypeCtxt(..) )
 import TcPat           ( badFieldCon )
-import TcSimplify      ( tcSimplifyIPs )
 import TcMType         ( tcInstTyVars, tcInstType, newHoleTyVarTy, zapToType,
                          newTyVarTy, newTyVarTys, zonkTcType, readHoleResult )
 import TcType          ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv),
@@ -235,11 +232,9 @@ tcMonoExpr in_expr@(OpApp arg1 op fix arg2) res_ty
 \begin{code}
 tcMonoExpr (HsLet binds expr) res_ty
   = tcBindsAndThen
-       combiner
+       HsLet
        binds                   -- Bindings to check
        (tcMonoExpr expr res_ty)
-  where
-    combiner is_rec bind expr = HsLet (mkMonoBind bind [] is_rec) expr
 
 tcMonoExpr in_expr@(HsCase scrut matches src_loc) res_ty
   = addSrcLoc src_loc                  $
@@ -657,39 +652,12 @@ tcMonoExpr (HsReify (Reify flavour name)) res_ty
     returnM (HsReify (ReifyOut flavour name))
   where
     tycon_name = case flavour of
-                  ReifyDecl -> DsMeta.decTyConName
-                  ReifyType -> DsMeta.typTyConName
+                  ReifyDecl -> DsMeta.declTyConName
+                  ReifyType -> DsMeta.typeTyConName
                   ReifyFixity -> pprPanic "tcMonoExpr: cant do reifyFixity yet" (ppr name)
 #endif GHCI
 \end{code}
 
-%************************************************************************
-%*                                                                     *
-\subsection{Implicit Parameter bindings}
-%*                                                                     *
-%************************************************************************
-
-\begin{code}
-tcMonoExpr (HsWith expr binds is_with) res_ty
-  = getLIE (tcMonoExpr expr res_ty)    `thenM` \ (expr', expr_lie) ->
-    mapAndUnzipM tc_ip_bind binds      `thenM` \ (avail_ips, binds') ->
-
-       -- If the binding binds ?x = E, we  must now 
-       -- discharge any ?x constraints in expr_lie
-    tcSimplifyIPs avail_ips expr_lie   `thenM` \ dict_binds ->
-    let
-       expr'' = HsLet (mkMonoBind dict_binds [] Recursive) expr'
-    in
-    returnM (HsWith expr'' binds' is_with)
-  where
-    tc_ip_bind (ip, expr)
-      = newTyVarTy openTypeKind                `thenM` \ ty ->
-       getSrcLocM                      `thenM` \ loc ->
-       newIPDict (IPBind ip) ip ty     `thenM` \ (ip', ip_inst) ->
-       tcMonoExpr expr ty              `thenM` \ expr' ->
-       returnM (ip_inst, (ip', expr'))
-\end{code}
-
 
 %************************************************************************
 %*                                                                     *
@@ -829,12 +797,17 @@ tcId name -- Look up the Id and instantiate its type
       Brack use_lvl ps_var lie_var
        | use_lvl > bind_lvl && not (isExternalName name)
        ->      -- E.g. \x -> [| h x |]
-                       -- We must behave as if the reference to x was
-                       --      h $(lift x)     
-                       -- We use 'x' itself as the splice proxy, used by 
-                       -- the desugarer to stitch it all back together
-                       -- NB: isExernalName is true of top level things, 
-                       -- and false of nested bindings
+               -- We must behave as if the reference to x was
+               --      h $(lift x)     
+               -- We use 'x' itself as the splice proxy, used by 
+               -- the desugarer to stitch it all back together.
+               -- If 'x' occurs many times we may get many identical
+               -- bindings of the same splice proxy, but that doesn't
+               -- matter, although it's a mite untidy.
+               --
+               -- NB: During type-checking, isExernalName is true of 
+               -- top level things, and false of nested bindings
+               -- Top-level things don't need lifting.
        
        let
            id_ty = idType id
@@ -857,11 +830,7 @@ tcId name  -- Look up the Id and instantiate its type
        returnM (HsVar id, id_ty))
 
       other -> 
-       let
-          use_lvl = metaLevel use_stage
-       in
-       checkTc (wellStaged bind_lvl use_lvl)
-               (badStageErr id bind_lvl use_lvl)       `thenM_`
+       checkWellStaged (quotes (ppr id)) bind_lvl use_stage    `thenM_`
 #endif
        -- This is the bit that handles the no-Template-Haskell case
        case isDataConWrapId_maybe id of
@@ -1078,12 +1047,6 @@ Boring and alphabetical:
 arithSeqCtxt expr
   = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr)
 
-
-badStageErr id bind_lvl use_lvl
-  = ptext SLIT("Stage error:") <+> quotes (ppr id) <+> 
-       hsep   [ptext SLIT("is bound at stage") <+> ppr bind_lvl,
-               ptext SLIT("but used at stage") <+> ppr use_lvl]
-
 parrSeqCtxt expr
   = hang (ptext SLIT("In a parallel array sequence:")) 4 (ppr expr)
 
@@ -1151,7 +1114,6 @@ missingStrictFields con fields
     header = ptext SLIT("Constructor") <+> quotes (ppr con) <+> 
             ptext SLIT("does not have the required strict field(s)") 
          
-
 missingFields :: DataCon -> [FieldLabel] -> SDoc
 missingFields con fields
   = ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:")