Commit c455d9a4 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

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
parent ef47b5c2
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment