Commit e26dd9a9 authored by simonpj's avatar simonpj

[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
parent 8f0c89cb
......@@ -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
......
......@@ -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 = []
......
......@@ -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:",
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment