More import tidying and fixing the stage 2 build
[ghc-hetmet.git] / compiler / typecheck / TcExpr.lhs
index d9e25c3..d249716 100644 (file)
@@ -1,4 +1,5 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[TcExpr]{Typecheck an expression}
@@ -11,81 +12,42 @@ module TcExpr ( tcPolyExpr, tcPolyExprNC,
 
 #ifdef GHCI    /* Only if bootstrapped */
 import {-# SOURCE #-}  TcSplice( tcSpliceExpr, tcBracket )
-import HsSyn           ( nlHsVar )
-import Id              ( Id, idName )
-import Name            ( isExternalName )
-import TcType          ( isTauTy )
-import TcEnv           ( checkWellStaged )
-import HsSyn           ( nlHsApp )
 import qualified DsMeta
 #endif
 
-import HsSyn           ( HsExpr(..), LHsExpr, ArithSeqInfo(..), recBindFields,
-                         HsMatchContext(..), HsRecordBinds, mkHsWrap,
-                         mkHsApp, mkLHsWrap )
-import TcHsSyn         ( hsLitType )
+import HsSyn
+import TcHsSyn
 import TcRnMonad
-import TcUnify         ( tcInfer, tcSubExp, tcFunResTy, tcGen, boxyUnify, subFunTys, zapToMonotype, stripBoxyType,
-                         boxySplitListTy, boxySplitTyConApp, wrapFunResCoercion, preSubType,
-                         unBox )
-import BasicTypes      ( Arity, isMarkedStrict )
-import Inst            ( newMethodFromName, newIPDict, instCall,
-                         newMethodWithGivenTy, instStupidTheta )
-import TcBinds         ( tcLocalBinds )
-import TcEnv           ( tcLookup, tcLookupDataCon, tcLookupField )
-import TcArrows                ( tcProc )
-import TcMatches       ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcBody,
-                         TcMatchCtxt(..) )
-import TcHsType                ( tcHsSigType, UserTypeCtxt(..) )
-import TcPat           ( tcOverloadedLit, addDataConStupidTheta, badFieldCon )
-import TcMType         ( tcInstTyVars, newFlexiTyVarTy, newBoxyTyVars,
-                         readFilledBox, zonkTcTypes )
-import TcType          ( TcType, TcSigmaType, TcRhoType, TvSubst,
-                         BoxySigmaType, BoxyRhoType, ThetaType,
-                         mkTyVarTys, mkFunTys, 
-                         tcMultiSplitSigmaTy, tcSplitFunTysN,
-                         tcSplitTyConApp_maybe, 
-                         isSigmaTy, mkFunTy, mkTyConApp, 
-                         exactTyVarsOfType, exactTyVarsOfTypes, 
-                         zipTopTvSubst, zipOpenTvSubst, substTys, substTyVar
-                       )
-import {- Kind parts of -} 
-       Type            ( argTypeKind )
-
-import Id              ( idType, recordSelectorFieldLabel,
-                         isRecordSelector, isNaughtyRecordSelector,
-                         isDataConId_maybe )
-import DataCon         ( DataCon, dataConFieldLabels, dataConStrictMarks,
-                         dataConSourceArity, 
-                         dataConWrapId, isVanillaDataCon, dataConUnivTyVars,
-                         dataConOrigArgTys ) 
-import Name            ( Name )
-import TyCon           ( FieldLabel, tyConStupidTheta, tyConDataCons,
-                         isEnumerationTyCon ) 
-import Type            ( substTheta, substTy )
-import Var             ( TyVar, tyVarKind )
-import VarSet          ( emptyVarSet, elemVarSet, unionVarSet )
-import TysWiredIn      ( boolTy, parrTyCon, tupleTyCon )
-import PrelNames       ( enumFromName, enumFromThenName, 
-                         enumFromToName, enumFromThenToName,
-                         enumFromToPName, enumFromThenToPName, negateName,
-                         hasKey
-                       )
-import PrimOp          ( tagToEnumKey )
-
+import TcUnify
+import BasicTypes
+import Inst
+import TcBinds
+import TcEnv
+import TcArrows
+import TcMatches
+import TcHsType
+import TcPat
+import TcMType
+import TcType
+import Id
+import DataCon
+import Name
+import TyCon
+import Type
+import Var
+import VarSet
+import TysWiredIn
+import PrelNames
+import PrimOp
 import DynFlags
-import StaticFlags     ( opt_NoMethodSharing )
-import HscTypes                ( TyThing(..) )
-import SrcLoc          ( Located(..), unLoc )
+import StaticFlags
+import HscTypes
+import SrcLoc
 import Util
-import ListSetOps      ( assocMaybe )
-import Maybes          ( catMaybes )
+import ListSetOps
+import Maybes
 import Outputable
 import FastString
-
-#ifdef DEBUG
-import TyCon           ( tyConArity )
-#endif
 \end{code}
 
 %************************************************************************
@@ -111,7 +73,7 @@ tcPolyExpr expr res_ty
 
 tcPolyExprNC expr res_ty 
   | isSigmaTy res_ty
-  = do { (gen_fn, expr') <- tcGen res_ty emptyVarSet (tcPolyExprNC expr)
+  = do { (gen_fn, expr') <- tcGen res_ty emptyVarSet (\_ -> tcPolyExprNC expr)
                -- Note the recursive call to tcPolyExpr, because the
                -- type may have multiple layers of for-alls
        ; return (mkLHsWrap gen_fn expr') }
@@ -208,9 +170,14 @@ tcExpr (HsLam match) res_ty
 
 tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty
  = do  { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
-       ; expr' <- tcPolyExpr expr sig_tc_ty
+
+       -- Remember to extend the lexical type-variable environment
+       ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (\ skol_tvs res_ty ->
+                            tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
+                            tcPolyExprNC expr res_ty)
+
        ; co_fn <- tcSubExp sig_tc_ty res_ty
-       ; return (mkHsWrap co_fn (ExprWithTySigOut expr' sig_ty)) }
+       ; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) }
 
 tcExpr (HsType ty) res_ty
   = failWithTc (text "Can't handle type argument:" <+> ppr ty)