X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=bc10f3e56ea65aa1d82e85d267f1112ebaf58fca;hp=2215c9bfb4e506051038376f4bfd901e25e83313;hb=c1681a73fa4ca4cf8758264ae387ac09a9e900d8;hpb=ab4bc0f16200a9d26272a9fcf21e669d6d19761d diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 2215c9b..bc10f3e 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -1,75 +1,69 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[TcSplice]{Template Haskell splices} + +TcSplice: Template Haskell splices \begin{code} module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket ) where #include "HsVersions.h" -import HscMain ( compileExpr ) -import TcRnDriver ( tcTopSrcDecls ) +import HscMain +import TcRnDriver -- These imports are the reason that TcSplice -- is very high up the module hierarchy -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 HsSyn ( HsBracket(..), HsExpr(..), HsSplice(..), LHsExpr, LHsDecl, - HsType, LHsType ) -import Convert ( convertToHsExpr, convertToHsDecls, convertToHsType, thRdrName ) -import RnExpr ( rnLExpr ) -import RnEnv ( lookupFixityRn, lookupSrcOcc_maybe, lookupImportedName ) -import RdrName ( RdrName, lookupLocalRdrEnv, isSrcRdrName ) -import RnTypes ( rnLHsType ) -import TcExpr ( tcMonoExpr ) -import TcHsSyn ( mkHsDictLet, zonkTopLExpr ) -import TcSimplify ( tcSimplifyTop, tcSimplifyBracket ) -import TcUnify ( boxyUnify, unBox ) -import TcType ( TcType, TcKind, BoxyRhoType, liftedTypeKind, mkAppTy, tcSplitSigmaTy ) -import TcEnv ( spliceOK, tcMetaTy, bracketOK ) -import TcMType ( newFlexiTyVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType ) -import TcHsType ( tcHsSigType, kcHsType ) -import TcIface ( tcImportDecl ) -import TypeRep ( Type(..), PredType(..), TyThing(..) ) -- For reification -import PrelNames ( thFAKE ) -import Name ( Name, NamedThing(..), nameOccName, nameModule, isExternalName, - nameIsLocalOrFrom ) -import NameEnv ( lookupNameEnv ) -import HscTypes ( lookupType, ExternalPackageState(..), emptyModDetails ) +import HsSyn +import Convert +import RnExpr +import RnEnv +import RdrName +import RnTypes +import TcExpr +import TcHsSyn +import TcSimplify +import TcUnify +import TcType +import TcEnv +import TcMType +import TcHsType +import TcIface +import TypeRep +import Name +import NameEnv +import HscTypes import OccName -import Var ( Id, TyVar, idType ) -import Module ( moduleString ) +import Var +import Module import TcRnMonad -import IfaceEnv ( lookupOrig ) -import Class ( Class, classExtraBigSig ) -import TyCon ( TyCon, tyConTyVars, synTyConDefn, - isSynTyCon, isNewTyCon, tyConDataCons, isPrimTyCon, isFunTyCon, - tyConArity, tyConStupidTheta, isUnLiftedTyCon ) -import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConStrictMarks, - dataConName, dataConFieldLabels, dataConWrapId, dataConIsInfix, - isVanillaDataCon ) -import Id ( idName, globalIdDetails ) -import IdInfo ( GlobalIdDetails(..) ) -import TysWiredIn ( mkListTy ) -import DsMeta ( expQTyConName, typeQTyConName, decTyConName, qTyConName, nameTyConName ) -import ErrUtils ( Message ) -import SrcLoc ( SrcSpan, noLoc, unLoc, getLoc ) +import IfaceEnv +import Class +import TyCon +import DataCon +import Id +import IdInfo +import TysWiredIn +import DsMeta +import DsExpr +import DsMonad hiding (Splice) +import ErrUtils +import SrcLoc import Outputable -import Unique ( Unique, Uniquable(..), getKey, mkUniqueGrimily ) - -import BasicTypes ( StrictnessMark(..), Fixity(..), FixityDirection(..) ) -import Panic ( showException ) -import FastString ( LitString ) +import Unique +import DynFlags +import PackageConfig +import BasicTypes +import Panic +import FastString -import GHC.Base ( unsafeCoerce#, Int#, Int(..) ) -- Should have a better home in the module hierarchy -import Monad ( liftM ) +import qualified Language.Haskell.TH as TH +-- THSyntax gives access to internal functions and data types +import qualified Language.Haskell.TH.Syntax as TH -#ifdef GHCI -import FastString ( mkFastString ) -#endif +import GHC.Exts ( unsafeCoerce#, Int#, Int(..) ) +import Control.Monad ( liftM ) \end{code} @@ -83,6 +77,7 @@ import FastString ( mkFastString ) tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId) kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind) + -- None of these functions add constraints to the LIE #ifndef GHCI tcSpliceExpr n e ty = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e) @@ -96,8 +91,20 @@ tcSpliceDecls e = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e) %* * %************************************************************************ +Note [Handling brackets] +~~~~~~~~~~~~~~~~~~~~~~~~ +Source: f = [| Just $(g 3) |] + The [| |] part is a HsBracket + +Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3} + The [| |] part is a HsBracketOut, containing *renamed* (not typechecked) expression + The "s7" is the "splice point"; the (g Int 3) part is a typechecked expression + +Desugared: f = do { s7 <- g Int 3 + ; return (ConE "Data.Maybe.Just" s7) } + \begin{code} -tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr Id) +tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId) tcBracket brack res_ty = getStage `thenM` \ level -> case bracketOK level of { @@ -368,17 +375,13 @@ runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn) -> LHsExpr Id -- Of type X -> TcM hs_syn -- Of type t runMeta convert expr - = do { hsc_env <- getTopEnv - ; tcg_env <- getGblEnv - ; this_mod <- getModule - ; let type_env = tcg_type_env tcg_env - rdr_env = tcg_rdr_env tcg_env - + = do { -- Desugar + ds_expr <- initDsTc (dsLExpr expr) -- Compile and link it; might fail if linking fails + ; hsc_env <- getTopEnv + ; src_span <- getSrcSpanM ; either_hval <- tryM $ ioToTcRn $ - HscMain.compileExpr - hsc_env this_mod - rdr_env type_env expr + HscMain.compileExpr hsc_env src_span ds_expr ; case either_hval of { Left exn -> failWithTc (mk_msg "compile and link" exn) ; Right hval -> do @@ -391,17 +394,17 @@ runMeta convert expr -- exception-cacthing thing so that if there are any lurking -- exceptions in the data structure returned by hval, we'll -- encounter them inside the try - either_tval <- tryAllM $ do - { th_syn <- TH.runQ (unsafeCoerce# hval) - ; case convert (getLoc expr) th_syn of - Left err -> do { addErrTc err; return Nothing } - Right hs_syn -> return (Just hs_syn) } - - ; case either_tval of - Right (Just v) -> return v - Right Nothing -> failM -- Error already in Tc monad - Left exn -> failWithTc (mk_msg "run" exn) -- Exception - }}} + either_th_syn <- tryAllM $ tryM $ TH.runQ $ unsafeCoerce# hval + ; case either_th_syn of + Left exn -> failWithTc (mk_msg "run" exn) + Right (Left exn) -> failM -- Error already in Tc monad + Right (Right th_syn) -> do + { either_hs_syn <- tryAllM $ return $! convert (getLoc expr) th_syn + ; case either_hs_syn of + Left exn -> failWithTc (mk_msg "interpret result of" exn) + Right (Left err) -> do { addErrTc err; failM } + Right (Right hs_syn) -> return hs_syn + }}}} where mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:", nest 2 (text (Panic.showException exn)), @@ -419,9 +422,21 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where qReport True msg = addErr (text msg) qReport False msg = addReport (text msg) - qCurrentModule = do { m <- getModule; return (moduleString m) } + qCurrentModule = do { m <- getModule; + return (moduleNameString (moduleName m)) } + -- ToDo: is throwing away the package name ok here? + qReify v = reify v - qRecover = recoverM + + -- For qRecover, discard error messages if + -- the recovery action is chosen. Otherwise + -- we'll only fail higher up. c.f. tryTcLIE_ + qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main + ; case mb_res of + Just val -> do { addMessages msgs -- There might be warnings + ; return val } + Nothing -> recover -- Discard all msgs + } qRunIO io = ioToTcRn io \end{code} @@ -470,9 +485,9 @@ reify th_name ; reifyThing thing } where - ppr_ns (TH.Name _ (TH.NameG TH.DataName mod)) = text "data" - ppr_ns (TH.Name _ (TH.NameG TH.TcClsName mod)) = text "tc" - ppr_ns (TH.Name _ (TH.NameG TH.VarName mod)) = text "var" + ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data" + ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc" + ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var" lookupThName :: TH.Name -> TcM Name lookupThName th_name@(TH.Name occ flavour) @@ -486,8 +501,7 @@ lookupThName th_name@(TH.Name occ flavour) Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig -> lookupImportedName rdr_name | otherwise -- Unqual, Qual - -> do { - mb_name <- lookupSrcOcc_maybe rdr_name + -> do { mb_name <- lookupSrcOcc_maybe rdr_name ; case mb_name of Just name -> return name Nothing -> failWithTc (notInScope th_name) } @@ -515,7 +529,8 @@ tcLookupTh name else do -- It's imported { (eps,hpt) <- getEpsAndHpt - ; case lookupType hpt (eps_PTE eps) name of + ; dflags <- getDOpts + ; case lookupType dflags hpt (eps_PTE eps) name of Just thing -> return (AGlobal thing) Nothing -> do { thing <- tcImportDecl name ; return (AGlobal thing) } @@ -555,9 +570,9 @@ reifyThing (AGlobal (ADataCon dc)) ; fix <- reifyFixity name ; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) } -reifyThing (ATcId id _ _) - = do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even - -- though it may be incomplete +reifyThing (ATcId {tct_id = id, tct_type = ty}) + = do { ty1 <- zonkTcType ty -- Make use of all the info we have, even + -- though it may be incomplete ; ty2 <- reifyType ty1 ; fix <- reifyFixity (idName id) ; return (TH.VarI (reifyName id) ty2 Nothing fix) } @@ -573,24 +588,26 @@ reifyTyCon tc | isFunTyCon tc = return (TH.PrimTyConI (reifyName tc) 2 False) | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc)) | isSynTyCon tc - = do { let (tvs, rhs) = synTyConDefn tc - ; rhs' <- reifyType rhs - ; return (TH.TyConI $ TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') } + = do { let (tvs, rhs) = synTyConDefn tc + ; rhs' <- reifyType rhs + ; return (TH.TyConI $ + TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') } reifyTyCon tc = do { cxt <- reifyCxt (tyConStupidTheta tc) - ; cons <- mapM reifyDataCon (tyConDataCons tc) + ; let tvs = tyConTyVars tc + ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc) ; let name = reifyName tc - tvs = reifyTyVars (tyConTyVars tc) + r_tvs = reifyTyVars tvs deriv = [] -- Don't know about deriving - decl | isNewTyCon tc = TH.NewtypeD cxt name tvs (head cons) deriv - | otherwise = TH.DataD cxt name tvs cons deriv + decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv + | otherwise = TH.DataD cxt name r_tvs cons deriv ; return (TH.TyConI decl) } -reifyDataCon :: DataCon -> TcM TH.Con -reifyDataCon dc +reifyDataCon :: [Type] -> DataCon -> TcM TH.Con +reifyDataCon tys dc | isVanillaDataCon dc - = do { arg_tys <- reifyTypes (dataConOrigArgTys dc) + = do { arg_tys <- reifyTypes (dataConInstOrigArgTys dc tys) ; let stricts = map reifyStrict (dataConStrictMarks dc) fields = dataConFieldLabels dc name = reifyName dc @@ -616,7 +633,7 @@ reifyClass cls ; ops <- mapM reify_op op_stuff ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) } where - (tvs, fds, theta, _, op_stuff) = classExtraBigSig cls + (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls fds' = map reifyFunDep fds reify_op (op, _) = do { ty <- reifyType (idType op) ; return (TH.SigD (reifyName op) ty) } @@ -654,7 +671,7 @@ reifyPred p@(IParam _ _) = noTH SLIT("implicit parameters") (ppr p) ------------------------------ reifyName :: NamedThing n => n -> TH.Name reifyName thing - | isExternalName name = mk_varg mod occ_str + | isExternalName name = mk_varg pkg_str mod_str occ_str | otherwise = TH.mkNameU occ_str (getKey (getUnique name)) -- Many of the things we reify have local bindings, and -- NameL's aren't supposed to appear in binding positions, so @@ -662,7 +679,9 @@ reifyName thing -- have free variables, we may need to generate NameL's for them. where name = getName thing - mod = moduleString (nameModule name) + mod = nameModule name + pkg_str = packageIdString (modulePackageId mod) + mod_str = moduleNameString (moduleName mod) occ_str = occNameString occ occ = nameOccName name mk_varg | OccName.isDataOcc occ = TH.mkNameG_d