[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

diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs
index ab94bdc..3414ab7 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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:",