[project @ 2002-11-04 15:33:29 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 c3dde2f..9b913d8 100644 (file)
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -10,21 +10,23 @@ module TcExpr ( tcExpr, tcExpr_id, tcMonoExpr ) where
 
 #ifdef GHCI    /* Only if bootstrapped */
 import {-# SOURCE #-}  TcSplice( tcSpliceExpr, tcBracket )
-import TcEnv           ( bracketOK )
+import HsSyn           ( HsReify(..), ReifyFlavour(..) )
+import TcType          ( isTauTy )
+import TcEnv           ( bracketOK, tcMetaTy, tcLookupGlobal,
+                         wellStaged, metaLevel )
 import TcSimplify      ( tcSimplifyBracket )
-import DsMeta          ( liftName )
+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, 
@@ -32,18 +34,16 @@ import Inst         ( InstOrigin(..),
                        )
 import TcBinds         ( tcBindsAndThen )
 import TcEnv           ( tcLookupClass, tcLookupGlobal_maybe, tcLookupIdLvl,
-                         tcLookupTyCon, tcLookupDataCon, tcLookupId,
-                         wellStaged, metaLevel
+                         tcLookupTyCon, tcLookupDataCon, tcLookupId
                        )
 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),
                          tcSplitFunTys, tcSplitTyConApp, mkTyVarTys,
-                         isSigmaTy, isTauTy, mkFunTy, mkFunTys,
+                         isSigmaTy, mkFunTy, mkFunTys,
                          mkTyConApp, mkClassPred, tcFunArgTy,
                          tyVarsOfTypes, isLinearPred,
                          liftedTypeKind, openTypeKind, 
@@ -53,7 +53,7 @@ import TcType         ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv),
 import FieldLabel      ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon )
 import Id              ( Id, idType, recordSelectorFieldLabel, isRecordSelector, isDataConWrapId_maybe )
 import DataCon         ( DataCon, dataConFieldLabels, dataConSig, dataConStrictMarks )
-import Name            ( Name, isExternalName )
+import Name            ( Name )
 import TyCon           ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons )
 import Subst           ( mkTopTyVarSubst, substTheta, substTy )
 import VarSet          ( emptyVarSet, elemVarSet )
@@ -233,11 +233,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                  $
@@ -621,10 +619,11 @@ tcMonoExpr (PArrSeqIn _) _
 #ifdef GHCI    /* Only if bootstrapped */
        -- Rename excludes these cases otherwise
 
-tcMonoExpr (HsSplice n expr) res_ty = tcSpliceExpr n expr res_ty
+tcMonoExpr (HsSplice n expr loc) res_ty = addSrcLoc loc (tcSpliceExpr n expr res_ty)
   
-tcMonoExpr (HsBracket brack) res_ty
-  = getStage                                   `thenM` \ level ->
+tcMonoExpr (HsBracket brack loc) res_ty
+  = addSrcLoc loc                      $
+    getStage                           `thenM` \ level ->
     case bracketOK level of {
        Nothing         -> failWithTc (illegalBracket level) ;
        Just next_level ->
@@ -646,34 +645,18 @@ tcMonoExpr (HsBracket brack) res_ty
     readMutVar pending_splices         `thenM` \ pendings ->
     returnM (HsBracketOut brack pendings)
     }
-#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)
+tcMonoExpr (HsReify (Reify flavour name)) res_ty
+  = addErrCtxt (ptext SLIT("At the reification of") <+> ppr name)      $
+    tcMetaTy  tycon_name       `thenM` \ reify_ty ->
+    unifyTauTy res_ty reify_ty `thenM_`
+    returnM (HsReify (ReifyOut flavour name))
   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'))
+    tycon_name = case flavour of
+                  ReifyDecl -> DsMeta.declTyConName
+                  ReifyType -> DsMeta.typeTyConName
+                  ReifyFixity -> pprPanic "tcMonoExpr: cant do reifyFixity yet" (ppr name)
+#endif GHCI
 \end{code}
 
 
@@ -833,7 +816,7 @@ tcId name   -- Look up the Id and instantiate its type
                    -- just going to flag an error for now
 
        setLIEVar lie_var       (
-       newMethodFromName orig id_ty liftName   `thenM` \ lift ->
+       newMethodFromName orig id_ty DsMeta.liftName    `thenM` \ lift ->
                -- Put the 'lift' constraint into the right LIE
        
        -- Update the pending splices
@@ -861,8 +844,8 @@ tcId name   -- Look up the Id and instantiate its type
        | want_method_inst fun_ty
        = tcInstType VanillaTv fun_ty           `thenM` \ (tyvars, theta, tau) ->
          newMethodWithGivenTy orig fun_id 
-               (mkTyVarTys tyvars) theta tau   `thenM` \ meth ->
-         loop (HsVar (instToId meth)) tau
+               (mkTyVarTys tyvars) theta tau   `thenM` \ meth_id ->
+         loop (HsVar meth_id) tau
 
     loop fun fun_ty 
        | isSigmaTy fun_ty