[project @ 2002-10-11 14:46:02 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 c83b46e..f424dbc 100644 (file)
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -9,14 +9,14 @@ module TcExpr ( tcExpr, tcExpr_id, tcMonoExpr ) where
 #include "HsVersions.h"
 
 #ifdef GHCI    /* Only if bootstrapped */
-import {-# SOURCE #-}  TcSplice( tcSpliceExpr )
+import {-# SOURCE #-}  TcSplice( tcSpliceExpr, tcBracket )
+import HsSyn           ( HsReify(..), ReifyFlavour(..) )
 import TcEnv           ( bracketOK, tcMetaTy )
 import TcSimplify      ( tcSimplifyBracket )
-import PrelNames       ( exprTyConName )
-import HsSyn           ( HsBracket(..) )
+import qualified DsMeta
 #endif
 
-import HsSyn           ( HsExpr(..), HsLit(..), ArithSeqInfo(..), 
+import HsSyn           ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
                          mkMonoBind, recBindFields
                        )
 import RnHsSyn         ( RenamedHsExpr, RenamedRecordBinds )
@@ -33,7 +33,7 @@ import Inst           ( InstOrigin(..),
                        )
 import TcBinds         ( tcBindsAndThen )
 import TcEnv           ( tcLookupClass, tcLookupGlobal_maybe, tcLookupIdLvl,
-                         tcLookupTyCon, tcLookupDataCon, tcLookupId,
+                         tcLookupTyCon, tcLookupDataCon, tcLookupId, tcLookupGlobal,
                          wellStaged, metaLevel
                        )
 import TcMatches       ( tcMatchesCase, tcMatchLambda, tcDoStmts )
@@ -63,7 +63,7 @@ import PrelNames      ( cCallableClassName, cReturnableClassName,
                          enumFromName, enumFromThenName, 
                          enumFromToName, enumFromThenToName,
                          enumFromToPName, enumFromThenToPName,
-                         ioTyConName, liftName
+                         ioTyConName
                        )
 import ListSetOps      ( minusList )
 import CmdLineOpts
@@ -622,10 +622,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 (ExpBr expr)) 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 ->
@@ -635,20 +636,35 @@ tcMonoExpr (HsBracket (ExpBr expr)) res_ty
        -- it again when we actually use it.
     newMutVar []                       `thenM` \ pending_splices ->
     getLIEVar                          `thenM` \ lie_var ->
-    newTyVarTy openTypeKind            `thenM` \ any_ty ->
 
     setStage (Brack next_level pending_splices lie_var) (
-       getLIE (tcMonoExpr expr any_ty)
-    )                                          `thenM` \ (expr', lie) ->
-    tcSimplifyBracket lie                      `thenM_`  
+       getLIE (tcBracket brack)
+    )                                  `thenM` \ (meta_ty, lie) ->
+    tcSimplifyBracket lie              `thenM_`  
 
-    tcMetaTy exprTyConName                     `thenM` \ meta_exp_ty ->
-    unifyTauTy res_ty meta_exp_ty              `thenM_`
+    unifyTauTy res_ty meta_ty          `thenM_`
 
        -- Return the original expression, not the type-decorated one
     readMutVar pending_splices         `thenM` \ pendings ->
-    returnM (HsBracketOut (ExpBr expr) pendings)
+    returnM (HsBracketOut brack pendings)
     }
+
+tcMonoExpr (HsReify (Reify flavour name)) res_ty
+  = addErrCtxt (ptext SLIT("At the reification of") <+> ppr name)      $
+    tcLookupGlobal name                `thenM` \ thing ->
+       -- For now, we can only reify top-level things
+       -- The complication for non-top-level things is just that 
+       -- they might be a TcId, and need zonking etc.
+
+    tcMetaTy  tycon_name       `thenM` \ reify_ty ->
+    unifyTauTy res_ty reify_ty `thenM_`
+
+    returnM (HsReify (ReifyOut flavour thing))
+  where
+    tycon_name = case flavour of
+                  ReifyDecl -> DsMeta.decTyConName
+                  ReifyType -> DsMeta.typTyConName
+                  ReifyFixity -> pprPanic "tcMonoExpr: cant do reifyFixity yet" (ppr name)
 #endif GHCI
 \end{code}
 
@@ -812,6 +828,7 @@ tcId name   -- Look up the Id and instantiate its type
   = tcLookupIdLvl name                 `thenM` \ (id, bind_lvl) ->
 
        -- Check for cross-stage lifting
+#ifdef GHCI
     getStage                           `thenM` \ use_stage -> 
     case use_stage of
       Brack use_lvl ps_var lie_var
@@ -835,7 +852,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
@@ -850,7 +867,8 @@ tcId name   -- Look up the Id and instantiate its type
        in
        checkTc (wellStaged bind_lvl use_lvl)
                (badStageErr id bind_lvl use_lvl)       `thenM_`
-
+#endif
+       -- This is the bit that handles the no-Template-Haskell case
        case isDataConWrapId_maybe id of
                Nothing       -> loop (HsVar id) (idType id)
                Just data_con -> inst_data_con id data_con