[project @ 2004-02-24 15:57:52 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcSplice.lhs

diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs
index 36a7220..ddd7ace 100644 (file)
--- a/ghc/compiler/typecheck/TcSplice.lhs
+++ b/ghc/compiler/typecheck/TcSplice.lhs
@@ -13,11 +13,10 @@ import TcRnDriver   ( tcTopSrcDecls )
        -- These imports are the reason that TcSplice 
        -- is very high up the module hierarchy
 
-import qualified Language.Haskell.TH.THSyntax as TH
-import qualified Language.Haskell.TH.THLib    as TH
+import qualified Language.Haskell.TH as TH
 -- THSyntax gives access to internal functions and data types
+import qualified Language.Haskell.TH.Syntax as TH
 
-import HscTypes                ( HscEnv(..) )
 import HsSyn           ( HsBracket(..), HsExpr(..), HsSplice(..), LHsExpr, LHsDecl, 
                          HsType, LHsType )
 import Convert         ( convertToHsExpr, convertToHsDecls, convertToHsType )
@@ -29,7 +28,7 @@ import TcExpr         ( tcCheckRho, tcMonoExpr )
 import TcHsSyn         ( mkHsLet, zonkTopLExpr )
 import TcSimplify      ( tcSimplifyTop, tcSimplifyBracket )
 import TcUnify         ( Expected, zapExpectedTo, zapExpectedType )
-import TcType          ( TcType, TcKind, openTypeKind, mkAppTy, tcSplitSigmaTy )
+import TcType          ( TcType, TcKind, liftedTypeKind, mkAppTy, tcSplitSigmaTy )
 import TcEnv           ( spliceOK, tcMetaTy, bracketOK, tcLookup )
 import TcMType         ( newTyVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType, zonkTcTyVar )
 import TcHsType                ( tcHsSigType, kcHsType )
@@ -37,7 +36,6 @@ import TypeRep                ( Type(..), PredType(..), TyThing(..) ) -- For reification
 import Name            ( Name, NamedThing(..), nameOccName, nameModule, isExternalName, mkInternalName )
 import OccName
 import Var             ( Id, TyVar, idType )
-import RdrName         ( RdrName )
 import Module          ( moduleUserString, mkModuleName )
 import TcRnMonad
 import IfaceEnv                ( lookupOrig )
@@ -54,15 +52,17 @@ import ErrUtils             ( Message )
 import SrcLoc          ( noLoc, unLoc, getLoc, noSrcLoc )
 import Outputable
 import Unique          ( Unique, Uniquable(..), getKey, mkUniqueGrimily )
-import IOEnv           ( IOEnv )
+
 import BasicTypes      ( StrictnessMark(..), Fixity(..), FixityDirection(..) )
-import Module          ( moduleUserString )
 import Panic           ( showException )
-import FastString      ( LitString, mkFastString )
-import FastTypes       ( iBox )
+import FastString      ( LitString )
 
 import GHC.Base                ( unsafeCoerce#, Int#, Int(..) )        -- Should have a better home in the module hierarchy
 import Monad           ( liftM )
+
+#ifdef GHCI
+import FastString      ( mkFastString )
+#endif
 \end{code}
 
 
@@ -100,6 +100,7 @@ tcBracket brack res_ty
        -- Typecheck expr to make sure it is valid,
        -- but throw away the results.  We'll type check
        -- it again when we actually use it.
+    recordThUse                                `thenM_`
     newMutVar []                       `thenM` \ pending_splices ->
     getLIEVar                          `thenM` \ lie_var ->
 
@@ -122,7 +123,7 @@ tc_bracket (VarBr v)
        -- Result type is Var (not Q-monadic)
 
 tc_bracket (ExpBr expr) 
-  = newTyVarTy openTypeKind    `thenM` \ any_ty ->
+  = newTyVarTy liftedTypeKind  `thenM` \ any_ty ->
     tcCheckRho expr any_ty     `thenM_`
     tcMetaTy expQTyConName
        -- Result type is Expr (= Q Exp)
@@ -159,8 +160,8 @@ tcSpliceExpr (HsSplice name expr) res_ty
        Just next_level -> 
 
     case level of {
-       Comp                   -> do { e <- tcTopSplice expr res_ty ;
-                                      returnM (unLoc e) };
+       Comp                   -> do { e <- tcTopSplice expr res_ty
+                                    ; returnM (unLoc e) } ;
        Brack _ ps_var lie_var ->  
 
        -- A splice inside brackets
@@ -169,7 +170,7 @@ tcSpliceExpr (HsSplice name expr) res_ty
        -- Here (h 4) :: Q Exp
        -- but $(h 4) :: forall a.a     i.e. anything!
 
-    zapExpectedType res_ty                     `thenM_`
+    zapExpectedType res_ty liftedTypeKind      `thenM_`
     tcMetaTy expQTyConName                     `thenM` \ meta_exp_ty ->
     setStage (Splice next_level) (
        setLIEVar lie_var          $
@@ -226,16 +227,19 @@ tcTopSpliceExpr expr meta_ty
   = checkNoErrs $      -- checkNoErrs: must not try to run the thing
                        --              if the type checker fails!
 
-    setStage topSpliceStage $
+    setStage topSpliceStage $ do
 
-       -- Typecheck the expression
-    getLIE (tcCheckRho expr meta_ty)   `thenM` \ (expr', lie) ->
+       
+    do { recordThUse   -- Record that TH is used (for pkg depdendency)
 
+       -- Typecheck the expression
+       ; (expr', lie) <- getLIE (tcCheckRho expr meta_ty)
+       
        -- Solve the constraints
-    tcSimplifyTop lie                  `thenM` \ const_binds ->
+       ; const_binds <- tcSimplifyTop lie
        
        -- And zonk it
-    zonkTopLExpr (mkHsLet const_binds expr')
+       ; zonkTopLExpr (mkHsLet const_binds expr') }
 \end{code}
 
 
@@ -481,7 +485,7 @@ mk_uniq :: Int# -> Unique
 mk_uniq u = mkUniqueGrimily (I# u)
 
 notInScope :: TH.Name -> SDoc
-notInScope th_name = quotes (text (show (TH.pprName th_name))) <+> 
+notInScope th_name = quotes (text (TH.pprint th_name)) <+> 
                     ptext SLIT("is not in scope at a reify")
        -- Ugh! Rather an indirect way to display the name