projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[project @ 2004-04-06 11:37:50 by simonpj]
[ghc-hetmet.git] / ghc / compiler / deSugar / DsMeta.hs
diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs
index 94f3496..dbd8fce 100644 (file)
--- a/ghc/compiler/deSugar/DsMeta.hs
+++ b/ghc/compiler/deSugar/DsMeta.hs
@@ -55,6 +55,9 @@ import BasicTypes ( isBoxed )
 import Packages          ( thPackage )
 import Outputable
 import Bag       ( bagToList )
+import FastString ( unpackFS )
+import ForeignCall ( Safety(..), ForeignCall(..), CCallConv(..),
+                     CCallTarget(..) )
 
 import Monad ( zipWithM )
 import List ( sortBy )
@@ -112,8 +115,9 @@ repTopDs group
                        val_ds  <- mapM rep_bind_group (hs_valds group) ;
                        tycl_ds <- mapM repTyClD (hs_tyclds group) ;
                        inst_ds <- mapM repInstD' (hs_instds group) ;
+                       for_ds <- mapM repForD (hs_fords group) ;
                        -- more needed
-                       return (de_loc $ sort_by_loc $ concat val_ds ++ catMaybes tycl_ds ++ inst_ds) }) ;
+                       return (de_loc $ sort_by_loc $ concat val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ;
 
        decl_ty <- lookupType decQTyConName ;
        let { core_list = coreList' decl_ty decls } ;
@@ -232,6 +236,36 @@ repInstD' (L loc (InstDecl ty binds _))            -- Ignore user pragmas for now
  where
    (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty)
 
+repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
+repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis) _))
+ = do MkC name' <- lookupLOcc name
+      MkC typ' <- repLTy typ
+      MkC cc' <- repCCallConv cc
+      MkC s' <- repSafety s
+      MkC str <- coreStringLit $ static
+                              ++ unpackFS ch ++ " "
+                              ++ unpackFS cn ++ " "
+                              ++ conv_cimportspec cis
+      dec <- rep2 forImpDName [cc', s', str, name', typ']
+      return (loc, dec)
+ where
+    conv_cimportspec (CLabel cls) = panic "repForD': CLabel Not handled"
+    conv_cimportspec (CFunction DynamicTarget) = "dynamic"
+    conv_cimportspec (CFunction (StaticTarget fs)) = unpackFS fs
+    conv_cimportspec CWrapper = "wrapper"
+    static = case cis of
+                 CFunction (StaticTarget _) -> "static "
+                 _ -> ""
+
+repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
+repCCallConv CCallConv = rep2 cCallName []
+repCCallConv StdCallConv = rep2 stdCallName []
+
+repSafety :: Safety -> DsM (Core TH.Safety)
+repSafety PlayRisky = rep2 unsafeName []
+repSafety (PlaySafe False) = rep2 safeName []
+repSafety (PlaySafe True) = rep2 threadsafeName []
+
 -------------------------------------------------------
 --                     Constructors
 -------------------------------------------------------
@@ -254,16 +288,16 @@ repBangTy (L _ (BangType str ty)) = do
 --                     Deriving clause
 -------------------------------------------------------
 
-repDerivs :: Maybe (LHsContext Name) -> DsM (Core [TH.Name])
+repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
 repDerivs Nothing = coreList nameTyConName []
-repDerivs (Just (L _ ctxt))
+repDerivs (Just ctxt)
   = do { strs <- mapM rep_deriv ctxt ; 
         coreList nameTyConName strs }
   where
-    rep_deriv :: LHsPred Name -> DsM (Core TH.Name)
+    rep_deriv :: LHsType Name -> DsM (Core TH.Name)
        -- Deriving clauses must have the simple H98 form
-    rep_deriv (L _ (HsClassP cls [])) = lookupOcc cls
-    rep_deriv other                  = panic "rep_deriv"
+    rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls
+    rep_deriv other                             = panic "rep_deriv"
 
 
 -------------------------------------------------------
@@ -387,7 +421,7 @@ repTy (HsOpTy ty1 n ty2)      = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
 repTy (HsParTy t)                = repLTy t
 repTy (HsNumTy i)                 =
   panic "DsMeta.repTy: Can't represent number types (for generics)"
-repTy (HsPredTy pred)             = repLPred pred
+repTy (HsPredTy pred)             = repPred pred
 repTy (HsKindSig ty kind)        = 
   panic "DsMeta.repTy: Can't represent explicit kind signatures yet"
 
@@ -648,10 +682,11 @@ rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
 rep_bind (L loc (FunBind fn infx [L _ (Match [] ty (GRHSs guards wheres ty2))]))
  = do { (ss,wherecore) <- repBinds wheres
        ; guardcore <- addBinds ss (repGuards guards)
-       ; fn' <- lookupLBinder fn
-       ; p   <- repPvar fn'
-       ; ans <- repVal p guardcore wherecore
-       ; return (loc, ans) }
+       ; fn'  <- lookupLBinder fn
+       ; p    <- repPvar fn'
+       ; ans  <- repVal p guardcore wherecore
+       ; ans' <- wrapGenSyns ss ans
+       ; return (loc, ans') }
 
 rep_bind (L loc (FunBind fn infx ms))
  =   do { ms1 <- mapM repClauseTup ms
@@ -663,8 +698,9 @@ rep_bind (L loc (PatBind pat (GRHSs guards wheres ty2)))
  =   do { patcore <- repLP pat 
         ; (ss,wherecore) <- repBinds wheres
        ; guardcore <- addBinds ss (repGuards guards)
-        ; ans <- repVal patcore guardcore wherecore
-        ; return (loc, ans) }
+        ; ans  <- repVal patcore guardcore wherecore
+       ; ans' <- wrapGenSyns ss ans
+        ; return (loc, ans') }
 
 rep_bind (L loc (VarBind v e))
  =   do { v' <- lookupBinder v 
@@ -1253,7 +1289,7 @@ templateHaskellNames = [
     bindSName, letSName, noBindSName, parSName,
     -- Dec
     funDName, valDName, dataDName, newtypeDName, tySynDName,
-    classDName, instanceDName, sigDName,
+    classDName, instanceDName, sigDName, forImpDName,
     -- Cxt
     cxtName,
     -- Strict
@@ -1267,6 +1303,12 @@ templateHaskellNames = [
     -- Type
     forallTName, varTName, conTName, appTName,
     tupleTName, arrowTName, listTName,
+    -- Callconv
+    cCallName, stdCallName,
+    -- Safety
+    unsafeName,
+    safeName,
+    threadsafeName,
 
     -- And the tycons
     qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
@@ -1395,6 +1437,7 @@ tySynDName    = libFun FSLIT("tySynD")    tySynDIdKey
 classDName    = libFun FSLIT("classD")    classDIdKey
 instanceDName = libFun FSLIT("instanceD") instanceDIdKey
 sigDName      = libFun FSLIT("sigD")      sigDIdKey
+forImpDName   = libFun FSLIT("forImpD")   forImpDIdKey
 
 -- type Ctxt = ...
 cxtName = libFun FSLIT("cxt") cxtIdKey
@@ -1423,6 +1466,15 @@ arrowTName  = libFun FSLIT("arrowT") arrowTIdKey
 listTName   = libFun FSLIT("listT")  listTIdKey
 appTName    = libFun FSLIT("appT")    appTIdKey
                         
+-- data Callconv = ...
+cCallName = libFun FSLIT("cCall") cCallIdKey
+stdCallName = libFun FSLIT("stdCall") stdCallIdKey
+
+-- data Safety = ...
+unsafeName     = libFun FSLIT("unsafe") unsafeIdKey
+safeName       = libFun FSLIT("safe") safeIdKey
+threadsafeName = libFun FSLIT("threadsafe") threadsafeIdKey
+             
 matchQTyConName         = libTc FSLIT("MatchQ")        matchQTyConKey
 clauseQTyConName        = libTc FSLIT("ClauseQ")       clauseQTyConKey
 expQTyConName           = libTc FSLIT("ExpQ")          expQTyConKey
@@ -1456,7 +1508,7 @@ fieldExpTyConKey        = mkPreludeTyConUnique 116
 fieldPatTyConKey        = mkPreludeTyConUnique 117
 nameTyConKey             = mkPreludeTyConUnique 118
 
---     IdUniques available: 200-299
+--     IdUniques available: 200-399
 --     If you want to change this, make sure you check in PrelNames
 
 returnQIdKey        = mkPreludeMiscIdUnique 200
@@ -1547,6 +1599,7 @@ tySynDIdKey       = mkPreludeMiscIdUnique 276
 classDIdKey       = mkPreludeMiscIdUnique 277
 instanceDIdKey    = mkPreludeMiscIdUnique 278
 sigDIdKey         = mkPreludeMiscIdUnique 279
+forImpDIdKey      = mkPreludeMiscIdUnique 297
 
 -- type Cxt = ...
 cxtIdKey            = mkPreludeMiscIdUnique 280
@@ -1561,7 +1614,7 @@ recCIdKey         = mkPreludeMiscIdUnique 284
 infixCIdKey       = mkPreludeMiscIdUnique 285
 
 -- type StrictType = ...
-strictTKey        = mkPreludeMiscIdUnique 2286
+strictTKey        = mkPreludeMiscIdUnique 286
 
 -- type VarStrictType = ...
 varStrictTKey     = mkPreludeMiscIdUnique 287
@@ -1574,3 +1627,13 @@ tupleTIdKey       = mkPreludeMiscIdUnique 294
 arrowTIdKey       = mkPreludeMiscIdUnique 295
 listTIdKey        = mkPreludeMiscIdUnique 296
 appTIdKey         = mkPreludeMiscIdUnique 293
+
+-- data Callconv = ...
+cCallIdKey      = mkPreludeMiscIdUnique 300
+stdCallIdKey    = mkPreludeMiscIdUnique 301
+
+-- data Safety = ...
+unsafeIdKey     = mkPreludeMiscIdUnique 305
+safeIdKey       = mkPreludeMiscIdUnique 306
+threadsafeIdKey = mkPreludeMiscIdUnique 307
+
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)