X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=bc10f3e56ea65aa1d82e85d267f1112ebaf58fca;hb=1723d79af0638a1e96e2ae9e41208f7b86872bbc;hp=a823884b96aeb7dd50db5538105314c2ea92229d;hpb=e8a591c1a3dbdeccec2dd2aacccd7435004b0d51;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index a823884..bc10f3e 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -1,77 +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 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 +import Module +import TcRnMonad +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 +import DynFlags +import PackageConfig +import BasicTypes +import Panic +import FastString + 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 OccName -import Var ( Id, TyVar, idType ) -import Module ( moduleName, moduleNameString, modulePackageId ) -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 DsExpr ( dsLExpr ) -import DsMonad ( initDsTc ) -import ErrUtils ( Message ) -import SrcLoc ( SrcSpan, noLoc, unLoc, getLoc ) -import Outputable -import Unique ( Unique, Uniquable(..), getKey, mkUniqueGrimily ) -import PackageConfig ( packageIdString ) -import BasicTypes ( StrictnessMark(..), Fixity(..), FixityDirection(..) ) -import Panic ( showException ) -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 +import GHC.Exts ( unsafeCoerce#, Int#, Int(..) ) +import Control.Monad ( liftM ) \end{code} @@ -85,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) @@ -98,6 +91,18 @@ 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 TcId) tcBracket brack res_ty @@ -372,7 +377,6 @@ runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn) runMeta convert expr = do { -- Desugar ds_expr <- initDsTc (dsLExpr expr) - -- Compile and link it; might fail if linking fails ; hsc_env <- getTopEnv ; src_span <- getSrcSpanM @@ -390,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)), @@ -497,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) } @@ -585,27 +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 - = case synTyConDefn tc of - Nothing -> noTH SLIT("type family") (ppr tc) - Just (tvs, rhs) -> - do { 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 @@ -631,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) }