From e26dd9a959b7b7810c2e2089940422092a95f2e3 Mon Sep 17 00:00:00 2001 From: simonpj Date: Wed, 6 Nov 2002 13:10:47 +0000 Subject: [PATCH] [project @ 2002-11-06 13:10:46 by simonpj] ------------------ Template Haskell stuff ------------------ a) Pretty printer for TH (thanks to Ian Lynagh) b) A declaration quote has type Q [Dec], not [Q Dec] as in the paper c) Foreign imports are part of THSyntax, and can be spliced in --- ghc/compiler/deSugar/DsMeta.hs | 38 +++++++++++++++++++++-------------- ghc/compiler/hsSyn/Convert.lhs | 12 ++++++++++- ghc/compiler/typecheck/TcSplice.lhs | 33 +++++++++++++++--------------- 3 files changed, 51 insertions(+), 32 deletions(-) diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index ab94bdc..3414ab7 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -131,7 +131,7 @@ dsReify r@(ReifyOut ReifyDecl name) -- Declarations ------------------------------------------------------- -repTopDs :: HsGroup Name -> DsM (Core [M.Decl]) +repTopDs :: HsGroup Name -> DsM (Core (M.Q [M.Dec])) repTopDs group = do { let { bndrs = groupBinders group } ; ss <- mkGenSyms bndrs ; @@ -151,8 +151,11 @@ repTopDs group -- more needed return (val_ds ++ catMaybes tycl_ds ++ inst_ds) }) ; - core_list <- coreList declTyConName decls ; - wrapNongenSyms ss core_list + decl_ty <- lookupType declTyConName ; + let { core_list = coreList' decl_ty decls } ; + q_decs <- repSequenceQ decl_ty core_list ; + + wrapNongenSyms ss q_decs -- Do *not* gensym top-level binders } @@ -404,7 +407,7 @@ repE (RecordConOut _ _ _) = panic "DsMeta.repE: No record construction yet" repE (RecordUpdOut _ _ _ _) = panic "DsMeta.repE: No record update yet" repE (ExprWithTySig e ty) = do { e1 <- repE e; t1 <- repTy ty; repSigExp e1 t1 } -repE (ArithSeqOut _ aseq) = +repE (ArithSeqIn aseq) = case aseq of From e -> do { ds1 <- repE e; repFrom ds1 } FromThen e1 e2 -> do @@ -650,6 +653,8 @@ repP (ConPatIn dc details) RecCon pairs -> error "No records in template haskell yet" InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs } } +repP (NPatIn l (Just _)) = panic "Can't cope with negative overloaded patterns yet (repP (NPatIn _ (Just _)))" +repP (NPatIn l Nothing) = do { a <- repOverloadedLiteral l; repPlit a } repP other = panic "Exotic pattern inside meta brackets" repListPat :: [Pat Name] -> DsM (Core M.Patt) @@ -733,17 +738,14 @@ wrapGenSyns tc_name binds body@(MkC b) -- Just like wrapGenSym, but don't actually do the gensym -- Instead use the existing name -- Only used for [Decl] -wrapNongenSyms :: [GenSymBind] - -> Core [M.Decl] -> DsM (Core [M.Decl]) -wrapNongenSyms binds body@(MkC b) - = go binds +wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a) +wrapNongenSyms binds (MkC body) + = do { binds' <- mapM do_one binds ; + return (MkC (mkLets binds' body)) } where - go [] = return body - go ((name,id) : binds) - = do { MkC body' <- go binds - ; MkC lit_str <- localVar name -- No gensym - ; return (MkC (Let (NonRec id lit_str) body')) - } + do_one (name,id) + = do { MkC lit_str <- localVar name -- No gensym + ; return (NonRec id lit_str) } void = placeHolderType @@ -980,6 +982,10 @@ repBindQ :: Type -> Type -- a and b repBindQ ty_a ty_b (MkC x) (MkC y) = rep2 bindQName [Type ty_a, Type ty_b, x, y] +repSequenceQ :: Type -> Core [M.Q a] -> DsM (Core (M.Q [a])) +repSequenceQ ty_a (MkC list) + = rep2 sequenceQName [Type ty_a, list] + ------------ Lists and Tuples ------------------- -- turn a list of patterns into a single pattern matching a list @@ -1036,7 +1042,7 @@ templateHaskellNames bindStName, letStName, noBindStName, parStName, fromName, fromThenName, fromToName, fromThenToName, funName, valName, liftName, - gensymName, returnQName, bindQName, + gensymName, returnQName, bindQName, sequenceQName, matchName, clauseName, funName, valName, dataDName, classDName, instName, protoName, tvarName, tconName, tappName, arrowTyConName, tupleTyConName, listTyConName, namedTyConName, @@ -1100,6 +1106,7 @@ liftName = varQual FSLIT("lift") liftIdKey gensymName = varQual FSLIT("gensym") gensymIdKey returnQName = varQual FSLIT("returnQ") returnQIdKey bindQName = varQual FSLIT("bindQ") bindQIdKey +sequenceQName = varQual FSLIT("sequenceQ") sequenceQIdKey -- type Mat = ... matchName = varQual FSLIT("match") matchIdKey @@ -1187,6 +1194,7 @@ classDIdKey = mkPreludeMiscIdUnique 215 instIdKey = mkPreludeMiscIdUnique 216 dataDIdKey = mkPreludeMiscIdUnique 217 +sequenceQIdKey = mkPreludeMiscIdUnique 218 plitIdKey = mkPreludeMiscIdUnique 220 pvarIdKey = mkPreludeMiscIdUnique 221 diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs index 904c89d..24d34f0 100644 --- a/ghc/compiler/hsSyn/Convert.lhs +++ b/ghc/compiler/hsSyn/Convert.lhs @@ -33,7 +33,9 @@ import TyCon ( DataConDetails(..) ) import Type ( Type ) import BasicTypes( Boxity(..), RecFlag(Recursive), NewOrData(..), StrictnessMark(..) ) -import FastString( mkFastString ) +import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..) ) +import HsDecls ( CImportSpec(..), ForeignImport(..), ForeignDecl(..) ) +import FastString( mkFastString, nilFS ) import Char ( ord, isAlphaNum ) import List ( partition ) import Outputable @@ -79,6 +81,14 @@ cvt_top (Instance tys ty decs) cvt_top (Proto nm typ) = SigD (Sig (vName nm) (cvtType typ) loc0) +cvt_top (Foreign (Import callconv safety from nm typ)) + = ForD (ForeignImport (vName nm) (cvtType typ) fi False loc0) + where fi = CImport CCallConv (PlaySafe True) c_header nilFS cis + (c_header', c_func') = break (== ' ') from + c_header = mkFastString c_header' + c_func = tail c_func' + cis = CFunction (StaticTarget (mkFastString c_func)) + noContext = [] noExistentials = [] noFunDeps = [] diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index 6f60abf..18f6996 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -24,7 +24,7 @@ import RnHsSyn ( RenamedHsExpr ) import TcExpr ( tcMonoExpr ) import TcHsSyn ( TcExpr, TypecheckedHsExpr, mkHsLet, zonkTopExpr ) import TcSimplify ( tcSimplifyTop ) -import TcType ( TcType, openTypeKind ) +import TcType ( TcType, openTypeKind, mkAppTy ) import TcEnv ( spliceOK, tcMetaTy ) import TcRnTypes ( TopEnv(..) ) import TcMType ( newTyVarTy ) @@ -32,7 +32,7 @@ import Name ( Name ) import TcRnMonad import TysWiredIn ( mkListTy ) -import DsMeta ( exprTyConName, declTyConName ) +import DsMeta ( exprTyConName, declTyConName, decTyConName, qTyConName ) import Outputable import GHC.Base ( unsafeCoerce# ) -- Should have a better home in the module hierarchy \end{code} @@ -70,13 +70,17 @@ tcBracket (ExpBr expr) = newTyVarTy openTypeKind `thenM` \ any_ty -> tcMonoExpr expr any_ty `thenM_` tcMetaTy exprTyConName + -- Result type is Expr (= Q Exp) tcBracket (DecBr decls) = tcTopSrcDecls decls `thenM_` - tcMetaTy declTyConName `thenM` \ decl_ty -> - returnM (mkListTy decl_ty) + tcMetaTy decTyConName `thenM` \ decl_ty -> + tcMetaTy qTyConName `thenM` \ q_ty -> + returnM (mkAppTy q_ty (mkListTy decl_ty)) + -- Result type is Q [Dec] \end{code} + %************************************************************************ %* * \subsection{Splicing an expression} @@ -163,9 +167,10 @@ tcTopSplice expr res_ty \begin{code} -- Always at top level tcSpliceDecls expr - = tcMetaTy declTyConName `thenM` \ meta_dec_ty -> + = tcMetaTy decTyConName `thenM` \ meta_dec_ty -> + tcMetaTy qTyConName `thenM` \ meta_q_ty -> setStage topSpliceStage ( - getLIE (tcMonoExpr expr (mkListTy meta_dec_ty)) + getLIE (tcMonoExpr expr (mkAppTy meta_q_ty (mkListTy meta_dec_ty))) ) `thenM` \ (expr', lie) -> -- Solve the constraints tcSimplifyTop lie `thenM` \ const_binds -> @@ -198,24 +203,20 @@ tcSpliceDecls expr \begin{code} runMetaE :: TypecheckedHsExpr -- Of type (Q Exp) -> TcM Meta.Exp -- Of type Exp -runMetaE e = runMeta tcRunQ e +runMetaE e = runMeta e -runMetaD :: TypecheckedHsExpr -- Of type [Q Dec] +runMetaD :: TypecheckedHsExpr -- Of type Q [Dec] -> TcM [Meta.Dec] -- Of type [Dec] -runMetaD e = runMeta run_decl e - where - run_decl :: [Meta.Decl] -> TcM [Meta.Dec] - run_decl ds = mappM tcRunQ ds +runMetaD e = runMeta e -- Warning: if Q is anything other than IO, we need to change this tcRunQ :: Meta.Q a -> TcM a tcRunQ thing = ioToTcRn thing -runMeta :: (x -> TcM t) -- :: X -> IO t - -> TypecheckedHsExpr -- Of type X +runMeta :: TypecheckedHsExpr -- Of type X -> TcM t -- Of type t -runMeta run_it expr :: TcM t +runMeta expr = getTopEnv `thenM` \ top_env -> getEps `thenM` \ eps -> getNameCache `thenM` \ name_cache -> @@ -241,7 +242,7 @@ runMeta run_it expr :: TcM t ioToTcRn (HscMain.compileExpr hsc_env pcs this_mod print_unqual expr) `thenM` \ hval -> - tryM (run_it (unsafeCoerce# hval)) `thenM` \ either_tval -> + tryM (tcRunQ (unsafeCoerce# hval)) `thenM` \ either_tval -> case either_tval of Left exn -> failWithTc (vcat [text "Exception when running compile-time code:", -- 1.7.10.4