module TcSplice( kcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
lookupThName_maybe,
+todoSession, todoTcM,
runQuasiQuoteExpr, runQuasiQuotePat, runAnnotation ) where
#include "HsVersions.h"
import SrcLoc
import Outputable
import Unique
-import Maybe
+import Data.Maybe
import BasicTypes
import Panic
import FastString
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]
; 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
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
-- 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 $