From c455d9a46cbe9b7fa0013a7bcadaa5c738944604 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 17:50:26 +0000 Subject: [PATCH] Fix a couple of stage-2 bogosities Mon Sep 18 16:58:39 EDT 2006 Manuel M T Chakravarty * Fix a couple of stage-2 bogosities Sun Aug 6 20:00:08 EDT 2006 Manuel M T Chakravarty * Fix a couple of stage-2 bogosities Fri Jul 28 06:27:06 EDT 2006 simonpj@microsoft.com --- compiler/typecheck/TcExpr.lhs | 14 ++++---------- compiler/typecheck/TcRnDriver.lhs | 20 ++++++++++---------- 2 files changed, 14 insertions(+), 20 deletions(-) diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index c0a9294..d609981 100644 --- 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 --- 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 -- 1.7.10.4