Index: ghc/compiler/deSugar/DsMeta.hs =================================================================== RCS file: /cvs/fptools/ghc/compiler/deSugar/DsMeta.hs,v retrieving revision 1.16 diff -u -r1.16 DsMeta.hs --- ghc/compiler/deSugar/DsMeta.hs 2002/10/31 13:13:04 1.16 +++ ghc/compiler/deSugar/DsMeta.hs 2002/11/05 02:55:17 @@ -372,7 +372,7 @@ 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 @@ -618,6 +618,8 @@ 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) Index: ghc/compiler/hsSyn/Convert.lhs =================================================================== RCS file: /cvs/fptools/ghc/compiler/hsSyn/Convert.lhs,v retrieving revision 1.8 diff -u -r1.8 Convert.lhs --- ghc/compiler/hsSyn/Convert.lhs 2002/10/31 13:13:05 1.8 +++ ghc/compiler/hsSyn/Convert.lhs 2002/11/05 02:55:17 @@ -33,7 +33,9 @@ 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 @@ -78,6 +80,14 @@ (HsPredTy (cvt_pred ty)) 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 = [] Index: ghc/compiler/typecheck/TcSplice.lhs =================================================================== RCS file: /cvs/fptools/ghc/compiler/typecheck/TcSplice.lhs,v retrieving revision 1.5 diff -u -r1.5 TcSplice.lhs --- ghc/compiler/typecheck/TcSplice.lhs 2002/10/31 13:13:05 1.5 +++ ghc/compiler/typecheck/TcSplice.lhs 2002/11/05 02:55:18 @@ -24,7 +24,7 @@ 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,8 @@ import TcRnMonad import TysWiredIn ( mkListTy ) -import DsMeta ( exprTyConName, declTyConName ) +-- 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} @@ -163,10 +164,17 @@ \begin{code} -- Always at top level tcSpliceDecls expr +{- = tcMetaTy declTyConName `thenM` \ meta_dec_ty -> setStage topSpliceStage ( getLIE (tcMonoExpr expr (mkListTy meta_dec_ty)) ) `thenM` \ (expr', lie) -> +-} + = tcMetaTy decTyConName `thenM` \ meta_dec_ty -> + tcMetaTy qTyConName `thenM` \ meta_q_ty -> + setStage topSpliceStage ( + getLIE (tcMonoExpr expr (mkAppTy meta_q_ty (mkListTy meta_dec_ty))) + ) `thenM` \ (expr', lie) -> -- Solve the constraints tcSimplifyTop lie `thenM` \ const_binds -> let @@ -200,12 +208,12 @@ -> TcM Meta.Exp -- Of type Exp runMetaE e = runMeta tcRunQ 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 + run_decl :: Meta.Q [Meta.Dec] -> TcM [Meta.Dec] + run_decl = tcRunQ -- Warning: if Q is anything other than IO, we need to change this tcRunQ :: Meta.Q a -> TcM a Index: libraries/haskell-src/Language/Haskell/THSyntax.hs =================================================================== RCS file: /cvs/fptools/libraries/haskell-src/Language/Haskell/THSyntax.hs,v retrieving revision 1.6 diff -u -r1.6 THSyntax.hs --- libraries/haskell-src/Language/Haskell/THSyntax.hs 2002/10/30 13:17:06 1.6 +++ libraries/haskell-src/Language/Haskell/THSyntax.hs 2002/11/05 02:55:24 @@ -13,6 +13,12 @@ type Q a = IO a +qIO :: IO a -> Q a +qIO = id + +runQ :: Q a -> IO a +runQ = id + returnQ :: a -> Q a returnQ = return @@ -45,6 +51,7 @@ | Char Char | String String | Rational Rational + deriving Show data Pat = Plit Lit -- { 5 or 'c' } @@ -54,6 +61,7 @@ | Ptilde Pat -- { ~p } | Paspat String Pat -- { x @ p } | Pwild -- { _ } + deriving Show @@ -79,20 +87,25 @@ | SigExp Exp Typ -- e :: t | Br Exp | Esc Exp + deriving Show --left out things implicit parameters, sections +-- XXX Aren't sections covered by Infix? data RightHandSide e = Guarded [(e,e)] -- f p { | e1 = e2 | e3 = e4 } where ds - | Normal e -- f p = { e } where ds + | Normal e -- f p { = e } where ds + deriving Show data Statement p e d = BindSt p e | LetSt [ d ] | NoBindSt e | ParSt [[Statement p e d]] + deriving Show data DotDot e = From e | FromThen e e | FromTo e e | FromThenTo e e e + deriving Show data Dec = Fun String [Clause Pat Exp Dec] -- { f p1 p2 = b where decs } @@ -102,18 +115,34 @@ | Class Cxt String [String] [Dec] -- { class Eq a => Ord a where ds } | Instance Cxt Typ [Dec] -- { instance Show w => Show [w] where ds } | Proto String Typ -- { length :: [a] -> Int } + | Foreign Foreign + deriving Show + +data Foreign = Import Callconv Safety String String Typ + -- | Export ... + deriving Show + +data Callconv = CCall | StdCall + deriving Show + +data Safety = Unsafe | Safe | Threadsafe + deriving Show type Cxt = [Typ] -- (Eq a, Ord b) data Con = Constr String [Typ] + deriving Show data Program = Program [ Dec ] + deriving Show -data Tag = Tuple Int | Arrow | List | TconName String deriving Eq +data Tag = Tuple Int | Arrow | List | TconName String + deriving (Eq, Show) data Typ = Tvar String -- a | Tcon Tag -- T or [] or (->) or (,,) etc | Tapp Typ Typ -- T a b + deriving Show --------------------------------------------------- -- Combinator based types