-- 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 )
import TcHsSyn ( mkHsLet, zonkTopLExpr )
import TcSimplify ( tcSimplifyTop, tcSimplifyBracket )
import TcUnify ( Expected, zapExpectedTo, zapExpectedType )
-import TcType ( TcType, TcKind, openTypeKind, mkAppTy, tcSplitSigmaTy )
-import TcEnv ( spliceOK, tcMetaTy, bracketOK, tcLookup )
+import TcType ( TcType, TcKind, liftedTypeKind, mkAppTy, tcSplitSigmaTy )
+import TcEnv ( spliceOK, tcMetaTy, bracketOK )
import TcMType ( newTyVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType, zonkTcTyVar )
import TcHsType ( tcHsSigType, kcHsType )
+import TcIface ( tcImportDecl )
import TypeRep ( Type(..), PredType(..), TyThing(..) ) -- For reification
-import Name ( Name, NamedThing(..), nameOccName, nameModule, isExternalName, mkInternalName )
+import Name ( Name, NamedThing(..), nameOccName, nameModule, isExternalName,
+ mkInternalName, nameIsLocalOrFrom )
+import NameEnv ( lookupNameEnv )
+import HscTypes ( lookupType, ExternalPackageState(..) )
import OccName
import Var ( Id, TyVar, idType )
-import RdrName ( RdrName )
import Module ( moduleUserString, mkModuleName )
import TcRnMonad
import IfaceEnv ( lookupOrig )
-
import Class ( Class, classBigSig )
import TyCon ( TyCon, tyConTheta, tyConTyVars, getSynTyConDefn, isSynTyCon, isNewTyCon, tyConDataCons )
import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConStrictMarks,
- dataConName, dataConFieldLabels, dataConWrapId )
+ dataConName, dataConFieldLabels, dataConWrapId, dataConIsInfix )
import Id ( idName, globalIdDetails )
import IdInfo ( GlobalIdDetails(..) )
import TysWiredIn ( mkListTy )
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}
-- 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 ->
-- 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)
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
-- 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 $
= 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}
-> TcM [TH.Dec] -- Of type [Dec]
runMetaD e = runMeta e
-runMeta :: LHsExpr Id -- Of type X
+runMeta :: LHsExpr Id -- Of type X
-> TcM t -- Of type t
runMeta expr
= do { hsc_env <- getTopEnv
reify :: TH.Name -> TcM TH.Info
reify th_name
= do { name <- lookupThName th_name
- ; thing <- tcLookup name
+ ; thing <- tcLookupTh name
-- ToDo: this tcLookup could fail, which would give a
-- rather unhelpful error message
; reifyThing thing
bogus_ns = OccName.varName -- Not yet recorded in the TH name
-- but only the unique matters
+tcLookupTh :: Name -> TcM TcTyThing
+-- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
+-- it gives a reify-related error message on failure, whereas in the normal
+-- tcLookup, failure is a bug.
+tcLookupTh name
+ = do { (gbl_env, lcl_env) <- getEnvs
+ ; case lookupNameEnv (tcl_env lcl_env) name of
+ Just thing -> returnM thing
+ Nothing -> do
+ { if nameIsLocalOrFrom (tcg_mod gbl_env) name
+ then -- It's defined in this module
+ case lookupNameEnv (tcg_type_env gbl_env) name of
+ Just thing -> return (AGlobal thing)
+ Nothing -> failWithTc (notInEnv name)
+
+ else do -- It's imported
+ { (eps,hpt) <- getEpsAndHpt
+ ; case lookupType hpt (eps_PTE eps) name of
+ Just thing -> return (AGlobal thing)
+ Nothing -> do { traceIf (text "tcLookupGlobal" <+> ppr name)
+ ; thing <- initIfaceTcRn (tcImportDecl name)
+ ; return (AGlobal thing) }
+ -- Imported names should always be findable;
+ -- if not, we fail hard in tcImportDecl
+ }}}
+
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
+notInEnv :: Name -> SDoc
+notInEnv name = quotes (ppr name) <+>
+ ptext SLIT("is not in the type environment at a reify")
+
------------------------------
reifyThing :: TcTyThing -> TcM TH.Info
-- The only reason this is monadic is for error reporting,
= do { arg_tys <- reifyTypes (dataConOrigArgTys dc)
; let stricts = map reifyStrict (dataConStrictMarks dc)
fields = dataConFieldLabels dc
- ; if null fields then
- return (TH.NormalC (reifyName dc) (stricts `zip` arg_tys))
+ name = reifyName dc
+ [a1,a2] = arg_tys
+ [s1,s2] = stricts
+ ; ASSERT( length arg_tys == length stricts )
+ if not (null fields) then
+ return (TH.RecC name (zip3 (map reifyName fields) stricts arg_tys))
+ else
+ if dataConIsInfix dc then
+ ASSERT( length arg_tys == 2 )
+ return (TH.InfixC (s1,a1) name (s1,a2))
else
- return (TH.RecC (reifyName dc) (zip3 (map reifyName fields) stricts arg_tys)) }
- -- NB: we don't remember whether the constructor was declared in an infix way
+ return (TH.NormalC name (stricts `zip` arg_tys)) }
------------------------------
reifyClass :: Class -> TcM TH.Dec
projects / ghc-hetmet.git / blobdiff