Fix a couple of stage-2 bogosities

Mon Sep 18 16:58:39 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Fix a couple of stage-2 bogosities
  Sun Aug  6 20:00:08 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * Fix a couple of stage-2 bogosities
    Fri Jul 28 06:27:06 EDT 2006  simonpj@microsoft.com

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index c0a9294..d609981 100644 (file)
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -12,7 +12,7 @@ module TcExpr ( tcPolyExpr, tcPolyExprNC,
 #ifdef GHCI    /* Only if bootstrapped */
 import {-# SOURCE #-}  TcSplice( tcSpliceExpr, tcBracket )
 import HsSyn           ( nlHsVar )
-import Id              ( Id )
+import Id              ( Id, idName )
 import Name            ( isExternalName )
 import TcType          ( isTauTy )
 import TcEnv           ( checkWellStaged )
@@ -54,7 +54,7 @@ import {- Kind parts of -}
 
 import Id              ( Id, idType, recordSelectorFieldLabel,
                          isRecordSelector, isNaughtyRecordSelector,
-                         isDataConId_maybe, idName )
+                         isDataConId_maybe )
 import DataCon         ( DataCon, dataConFieldLabels, dataConStrictMarks,
                          dataConSourceArity, 
                          dataConWrapId, isVanillaDataCon, dataConUnivTyVars,
@@ -965,16 +965,10 @@ thLocalId orig id id_ty th_bind_lvl
        ; case use_stage of
            Brack use_lvl ps_var lie_var | use_lvl > th_bind_lvl
                  -> thBrackId orig id ps_var lie_var
-           other -> checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage
+           other -> do { checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage
+                       ; return id }
        }
 
-thLocalId orig id_name id th_bind_lvl (Brack use_lvl ps_var lie_var)
-  | use_lvl > th_bind_lvl
-  = thBrackId 
-thLocalId orig id_name id th_bind_lvl use_stage
-  = do { checkWellStaged 
-       ; return id }
-
 --------------------------------------
 thBrackId orig id ps_var lie_var
   | isExternalName id_name

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 0a4895f..9747c22 100644 (file)
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -88,7 +88,7 @@ import HsSyn          ( HsStmtContext(..), Stmt(..), HsExpr(..),
                          HsLocalBinds(..), HsValBinds(..),
                          LStmt, LHsExpr, LHsType, mkMatch, emptyLocalBinds,
                          collectLStmtsBinders, collectLStmtBinders, nlVarPat,
-                         mkFunBind, placeHolderType, noSyntaxExpr )
+                         mkFunBind, placeHolderType, noSyntaxExpr, nlHsTyApp )
 import RdrName         ( GlobalRdrElt(..), globalRdrEnvElts,
                          unQualOK, lookupLocalRdrEnv, extendLocalRdrEnv )
 import RnSource                ( addTcgDUs )
@@ -97,6 +97,7 @@ import TcHsType               ( kcHsType )
 import TcMType         ( zonkTcType, zonkQuantifiedTyVar )
 import TcMatches       ( tcStmts, tcDoStmt )
 import TcSimplify      ( tcSimplifyInteractive, tcSimplifyInfer )
+import TcGadt          ( emptyRefinement )
 import TcType          ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, isTauTy,
                          isUnLiftedType, tyClsNamesOfDFunHead, tyClsNamesOfType, isUnitTy )
 import TcEnv           ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
@@ -113,7 +114,7 @@ import MkId         ( unsafeCoerceId )
 import TyCon           ( tyConName )
 import TysWiredIn      ( mkListTy, unitTy )
 import IdInfo          ( GlobalIdDetails(..) )
-import {- Kind parts of -} Type                ( Kind, eqKind )
+import {- Kind parts of -} Type                ( Kind )
 import Var             ( globaliseId )
 import Name            ( isBuiltInSyntax, isInternalName )
 import OccName         ( isTcOcc )
@@ -983,6 +984,8 @@ tcGhciStmts stmts
            io_ty     = mkTyConApp ioTyCon [] ;
            ret_ty    = mkListTy unitTy ;
            io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
+           tc_io_stmts stmts = tcStmts DoExpr (tcDoStmt io_ty) stmts 
+                                       (emptyRefinement, io_ret_ty) ;
 
            names = map unLoc (collectLStmtsBinders stmts) ;
 
@@ -997,19 +1000,16 @@ tcGhciStmts stmts
                -- then the type checker would instantiate x..z, and we wouldn't
                -- get their *polymorphic* values.  (And we'd get ambiguity errs
                -- if they were overloaded, since they aren't applied to anything.)
-           mk_return ids = nlHsApp (mkHsTyApp ret_id [ret_ty]) 
+           mk_return ids = nlHsApp (nlHsTyApp ret_id [ret_ty]) 
                                    (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
-           mk_item id = nlHsApp (noLoc $ unsafeCoerce)
-                                (nlHsVar id)
- 
-            unsafeCoerce x = Cast x (mkUnsafeCoercion [idType id, unitTy]) 
+           mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy])
+                                (nlHsVar id) 
         } ;
 
        -- OK, we're ready to typecheck the stmts
        traceTc (text "tcs 2") ;
-       ((tc_stmts, ids), lie) <- getLIE $ 
-                                 tcStmts DoExpr (tcDoStmt io_ty) stmts io_ret_ty $ \ _ ->
-                                 mappM tcLookupId names ;
+       ((tc_stmts, ids), lie) <- getLIE $ tc_io_stmts stmts $ \ _ ->
+                                          mappM tcLookupId names ;
                                        -- Look up the names right in the middle,
                                        -- where they will all be in scope