import SrcLoc ( noSrcLoc, unLoc, Located(..), SrcSpan, srcLocSpan )
import Maybe ( catMaybes )
import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) )
-import BasicTypes ( NewOrData(..), isBoxed )
+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 )
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 } ;
where
msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
-repInstD' (L loc (InstDecl ty binds _))
- -- Ignore user pragmas for now
- = do { cxt1 <- repContext cxt
- ; inst_ty1 <- repPred (HsClassP cls tys)
- ; ss <- mkGenSyms (collectHsBindBinders binds)
- ; binds1 <- addBinds ss (rep_binds binds)
- ; decls1 <- coreList decQTyConName binds1
- ; decls2 <- wrapNongenSyms ss decls1
- -- wrapNonGenSyms: do not clone the class op names!
- -- They must be called 'op' etc, not 'op34'
- ; i <- repInst cxt1 inst_ty1 decls2
+repInstD' (L loc (InstDecl ty binds _)) -- Ignore user pragmas for now
+ = do { i <- addTyVarBinds tvs $ \tv_bndrs ->
+ -- We must bring the type variables into scope, so their occurrences
+ -- don't fail, even though the binders don't appear in the resulting
+ -- data structure
+ do { cxt1 <- repContext cxt
+ ; inst_ty1 <- repPred (HsClassP cls tys)
+ ; ss <- mkGenSyms (collectHsBindBinders binds)
+ ; binds1 <- addBinds ss (rep_binds binds)
+ ; decls1 <- coreList decQTyConName binds1
+ ; decls2 <- wrapNongenSyms ss decls1
+ -- wrapNonGenSyms: do not clone the class op names!
+ -- They must be called 'op' etc, not 'op34'
+ ; repInst cxt1 inst_ty1 decls2 }
+
; return (loc, i)}
where
- (_, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty)
+ (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
-- 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"
-------------------------------------------------------
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"
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
= 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
bindSName, letSName, noBindSName, parSName,
-- Dec
funDName, valDName, dataDName, newtypeDName, tySynDName,
- classDName, instanceDName, sigDName,
+ classDName, instanceDName, sigDName, forImpDName,
-- Cxt
cxtName,
-- Strict
-- Type
forallTName, varTName, conTName, appTName,
tupleTName, arrowTName, listTName,
+ -- Callconv
+ cCallName, stdCallName,
+ -- Safety
+ unsafeName,
+ safeName,
+ threadsafeName,
-- And the tycons
qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
tH_LIB_Name = mkModuleName "Language.Haskell.TH.Lib"
thSyn :: Module
--- NB: the TH.Syntax module comes from the "haskell-src" package
+-- NB: the TH.Syntax module comes from the "template-haskell" package
thSyn = mkModule thPackage tH_SYN_Name
thLib = mkModule thPackage tH_LIB_Name
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
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
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
classDIdKey = mkPreludeMiscIdUnique 277
instanceDIdKey = mkPreludeMiscIdUnique 278
sigDIdKey = mkPreludeMiscIdUnique 279
+forImpDIdKey = mkPreludeMiscIdUnique 297
-- type Cxt = ...
cxtIdKey = mkPreludeMiscIdUnique 280
infixCIdKey = mkPreludeMiscIdUnique 285
-- type StrictType = ...
-strictTKey = mkPreludeMiscIdUnique 2286
+strictTKey = mkPreludeMiscIdUnique 286
-- type VarStrictType = ...
varStrictTKey = mkPreludeMiscIdUnique 287
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
+
projects / ghc-hetmet.git / blobdiff