X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=cd9170ee67960a8ca3e15fa0a1372a3a4f93eb01;hb=63489d40bdee972656ff115ab2309b809c0e39fc;hp=63c13e35db0b2cf2b018c629b084c3bce6508928;hpb=a99906e5272be7c6212327a32c83eac0a9b08b4b;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 63c13e3..cd9170e 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -15,6 +15,7 @@ TcSplice: Template Haskell splices
 
 module TcSplice( kcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
                  lookupThName_maybe,
+todoSession, todoTcM,
                  runQuasiQuoteExpr, runQuasiQuotePat, runAnnotation ) where
 
 #include "HsVersions.h"
@@ -64,7 +65,7 @@ import ErrUtils
 import SrcLoc
 import Outputable
 import Unique
-import Maybe
+import Data.Maybe
 import BasicTypes
 import Panic
 import FastString
@@ -81,6 +82,65 @@ import GHC.Desugar      ( AnnotationWrapper(..) )
 
 import GHC.Exts		( unsafeCoerce#, Int#, Int(..) )
 import System.IO.Error
+
+
+--here for every bad reason :-)
+import InstEnv
+import FamInstEnv
+--Session
+todoSession :: HscEnv -> Name -> IO (Messages, Maybe (LHsDecl RdrName))
+todoSession hsc_env name
+  = initTcPrintErrors hsc_env iNTERACTIVE $ 
+    setInteractiveContext hsc_env (hsc_IC hsc_env) $
+    todoTcM name
+
+
+todoTcM :: Name -> TcM (LHsDecl RdrName)
+todoTcM name = do
+  tcTyThing <- TcEnv.tcLookup name
+  thInfo <- TcSplice.reifyThing tcTyThing
+  let Just thDec = thGetDecFromInfo thInfo --BUG!
+  let Right [hsdecl] = Convert.convertToHsDecls
+        (error "srcspan of different package?")
+        [thDec]
+  return hsdecl
+
+thGetDecFromInfo :: TH.Info -> Maybe TH.Dec
+thGetDecFromInfo (TH.ClassI dec) = Just dec
+thGetDecFromInfo (TH.ClassOpI {}) = error "classop"
+thGetDecFromInfo (TH.TyConI dec) = Just dec
+thGetDecFromInfo (TH.PrimTyConI {}) = Nothing --error "sometimes we can invent a signature? or it's better not to?"
+thGetDecFromInfo (TH.DataConI {}) = error "datacon"
+thGetDecFromInfo (TH.VarI _name _type (Just dec) _fixity) = Just dec
+thGetDecFromInfo (TH.VarI _name _type Nothing _fixity) = error "vari"
+thGetDecFromInfo (TH.TyVarI {}) = Nothing --tyvars don't have decls? they kinda have a type though...
+
+setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
+setInteractiveContext hsc_env icxt thing_inside 
+  = let -- Initialise the tcg_inst_env with instances from all home modules.  
+        -- This mimics the more selective call to hptInstances in tcRnModule.
+	(home_insts, home_fam_insts) = hptInstances hsc_env (\mod -> True)
+    in
+    updGblEnv (\env -> env { 
+	tcg_rdr_env      = ic_rn_gbl_env icxt,
+	tcg_inst_env     = extendInstEnvList    (tcg_inst_env env) home_insts,
+	tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env env) 
+                                                home_fam_insts 
+      }) $
+
+    tcExtendGhciEnv (ic_tmp_ids icxt) $
+        -- tcExtendGhciEnv does lots: 
+        --   - it extends the local type env (tcl_env) with the given Ids,
+        --   - it extends the local rdr env (tcl_rdr) with the Names from 
+        --     the given Ids
+        --   - it adds the free tyvars of the Ids to the tcl_tyvars
+        --     set.
+        --
+        -- later ids in ic_tmp_ids must shadow earlier ones with the same
+        -- OccName, and tcExtendIdEnv implements this behaviour.
+
+    do	{ traceTc (text "setIC" <+> ppr (ic_tmp_ids icxt))
+ 	; thing_inside }
 \end{code}
 
 Note [Template Haskell levels]
@@ -233,7 +293,7 @@ tcBracket brack res_ty
        ; tcSimplifyBracket lie
 
 	-- Make the expected type have the right shape
-       ; boxyUnify meta_ty res_ty
+       ; _ <- boxyUnify meta_ty res_ty
 
 	-- Return the original expression, not the type-decorated one
        ; pendings <- readMutVar pending_splices
@@ -257,17 +317,17 @@ tc_bracket use_lvl (VarBr name) 	-- Note [Quoting names]
 
 tc_bracket _ (ExpBr expr) 
   = do	{ any_ty <- newFlexiTyVarTy liftedTypeKind
-	; tcMonoExprNC expr any_ty  -- NC for no context; tcBracket does that
+	; _ <- tcMonoExprNC expr any_ty  -- NC for no context; tcBracket does that
 	; tcMetaTy expQTyConName }
 	-- Result type is Expr (= Q Exp)
 
 tc_bracket _ (TypBr typ) 
-  = do	{ tcHsSigTypeNC ThBrackCtxt typ
+  = do	{ _ <- tcHsSigTypeNC ThBrackCtxt typ
 	; tcMetaTy typeQTyConName }
 	-- Result type is Type (= Q Typ)
 
 tc_bracket _ (DecBr decls)
-  = do	{  tcTopSrcDecls emptyModDetails decls
+  = do	{ _ <- tcTopSrcDecls emptyModDetails decls
 	-- Typecheck the declarations, dicarding the result
 	-- We'll get all that stuff later, when we splice it in
 
@@ -312,7 +372,7 @@ tcSpliceExpr (HsSplice name expr) res_ty
 	-- Here (h 4) :: Q Exp
 	-- but $(h 4) :: forall a.a 	i.e. anything!
 
-      unBox res_ty
+      _ <- unBox res_ty
       meta_exp_ty <- tcMetaTy expQTyConName
       expr' <- setStage (Splice next_level) (
                  setLIEVar lie_var    $