X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsMeta.hs;h=da87898eb320f0f65942ff672a94f9eeceaeda9f;hb=c244ae2a89f4ce85800e6eaa587a35b9c48ef4a9;hp=288885dee803b13e3b598176676e35e2c1ae12b6;hpb=cb2be98ac73ffcc2e2cd631de403e83569a12b4d;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index 288885d..da87898 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -51,10 +51,13 @@ import CoreUtils ( exprType ) 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 ) @@ -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 } ; @@ -213,20 +217,54 @@ repTyClD (L loc d) = do { dsWarn (loc, hang msg 4 (ppr d)) ; 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 @@ -250,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 (L _ (HsClassP cls [])))) = lookupOcc cls + rep_deriv other = panic "rep_deriv" ------------------------------------------------------- @@ -1154,7 +1192,7 @@ repOverloadedLiteral :: HsOverLit -> DsM (Core TH.Lit) repOverloadedLiteral (HsIntegral i _) = do { lit <- mk_integer i; repLiteral lit } repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral lit } -- The type Rational will be in the environment, becuase - -- the smart constructor 'THSyntax.rationalL' uses it in its type, + -- the smart constructor 'TH.Syntax.rationalL' uses it in its type, -- and rationalL is sucked in when any TH stuff is used --------------- Miscellaneous ------------------- @@ -1249,7 +1287,7 @@ templateHaskellNames = [ bindSName, letSName, noBindSName, parSName, -- Dec funDName, valDName, dataDName, newtypeDName, tySynDName, - classDName, instanceDName, sigDName, + classDName, instanceDName, sigDName, forImpDName, -- Cxt cxtName, -- Strict @@ -1263,6 +1301,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, @@ -1271,11 +1315,11 @@ templateHaskellNames = [ varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName, typeTyConName, matchTyConName, clauseTyConName] -tH_SYN_Name = mkModuleName "Language.Haskell.TH.THSyntax" -tH_LIB_Name = mkModuleName "Language.Haskell.TH.THLib" +tH_SYN_Name = mkModuleName "Language.Haskell.TH.Syntax" +tH_LIB_Name = mkModuleName "Language.Haskell.TH.Lib" thSyn :: Module --- NB: the THSyntax 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 @@ -1288,7 +1332,7 @@ libTc = mk_known_key_name thLib OccName.tcName thFun = mk_known_key_name thSyn OccName.varName thTc = mk_known_key_name thSyn OccName.tcName --------------------- THSyntax ----------------------- +-------------------- TH.Syntax ----------------------- qTyConName = thTc FSLIT("Q") qTyConKey nameTyConName = thTc FSLIT("Name") nameTyConKey fieldExpTyConName = thTc FSLIT("FieldExp") fieldExpTyConKey @@ -1312,7 +1356,7 @@ mkNameG_tcName = thFun FSLIT("mkNameG_tc") mkNameG_tcIdKey mkNameUName = thFun FSLIT("mkNameU") mkNameUIdKey --------------------- THLib ----------------------- +-------------------- TH.Lib ----------------------- -- data Lit = ... charLName = libFun FSLIT("charL") charLIdKey stringLName = libFun FSLIT("stringL") stringLIdKey @@ -1391,6 +1435,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 @@ -1419,6 +1464,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 @@ -1452,7 +1506,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 @@ -1543,6 +1597,7 @@ tySynDIdKey = mkPreludeMiscIdUnique 276 classDIdKey = mkPreludeMiscIdUnique 277 instanceDIdKey = mkPreludeMiscIdUnique 278 sigDIdKey = mkPreludeMiscIdUnique 279 +forImpDIdKey = mkPreludeMiscIdUnique 297 -- type Cxt = ... cxtIdKey = mkPreludeMiscIdUnique 280 @@ -1557,7 +1612,7 @@ recCIdKey = mkPreludeMiscIdUnique 284 infixCIdKey = mkPreludeMiscIdUnique 285 -- type StrictType = ... -strictTKey = mkPreludeMiscIdUnique 2286 +strictTKey = mkPreludeMiscIdUnique 286 -- type VarStrictType = ... varStrictTKey = mkPreludeMiscIdUnique 287 @@ -1570,3 +1625,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 +