Commit cbdeae8f authored by simonpj's avatar simonpj

[project @ 2001-05-24 13:59:09 by simonpj]

------------------------------------------------------
	More stuff towards generalising 'foreign' declarations
	------------------------------------------------------

This is the second step towards generalising 'foreign' declarations to
handle langauges other than C.  Now I can handle

  foreign import dotnet type T
  foreign import dotnet "void Foo.Baz.f( T )" f :: T -> IO ()



			** WARNING **
	I believe that all the foreign stuff for C should
	work exactly as before, but I have not tested it
	thoroughly.  Sven, Manuel, Marcin: please give it a
	whirl and compare old with new output.


Lots of fiddling around with data types.  The main changes are

* HsDecls.lhs
	The ForeignDecl type and its friends
	Note also the ForeignType constructor to TyClDecl

* ForeignCall.lhs
	Here's where the stuff that survives right through
	compilation lives

* TcForeign.lhs DsForeign.lhs
	Substantial changes driven by the new data types

* Parser.y ParseIface.y RnSource
	Just what you'd expect
parent f70aaa98
......@@ -28,7 +28,7 @@ import Unique ( Unique{-instance Eq-} )
import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply,
UniqSupply )
import CmdLineOpts ( opt_EmitCExternDecls )
import ForeignCall ( ForeignCall(..), CCallSpec(..), isDynamicTarget )
import ForeignCall ( ForeignCall(..), CCallSpec(..), isDynamicTarget, isCasmTarget )
import StgSyn ( StgOp(..) )
import Panic ( panic )
import FastTypes
......@@ -341,9 +341,9 @@ flatAbsC (CSwitch discrim alts deflt)
= flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) ->
returnFlt ( (tag, alt_heres), alt_tops )
flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _ is_asm)) uniq) args _)
| is_dynamic -- Emit a typedef if its a dynamic call
|| (opt_EmitCExternDecls && not is_asm) -- or we want extern decls
flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _)) uniq) args _)
| is_dynamic -- Emit a typedef if its a dynamic call
|| (opt_EmitCExternDecls && not (isCasmTarget target)) -- or we want extern decls
= returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args)
where
is_dynamic = isDynamicTarget target
......
......@@ -46,7 +46,7 @@ import Name ( NamedThing(..) )
import DataCon ( dataConWrapId )
import Maybes ( maybeToBool, catMaybes )
import PrimOp ( primOpNeedsWrapper )
import ForeignCall ( ForeignCall(..), isDynamicTarget )
import ForeignCall ( ForeignCall(..) )
import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize )
import SMRep ( pprSMRep )
import Unique ( pprUnique, Unique{-instance NamedThing-} )
......@@ -284,7 +284,7 @@ pprAbsC (CCallProfCtrMacro op as) _
pprAbsC (CCallProfCCMacro op as) _
= hcat [ptext op, lparen,
hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
pprAbsC stmt@(CCallTypedef is_tdef (CCallSpec op_str cconv _ _) uniq results args) _
pprAbsC stmt@(CCallTypedef is_tdef (CCallSpec op_str cconv _) uniq results args) _
= hsep [ ptext (if is_tdef then SLIT("typedef") else SLIT("extern"))
, ccall_res_ty
, fun_nm
......@@ -775,13 +775,13 @@ Amendment to the above: if we can GC, we have to:
that the runtime check that PerformGC is being used sensibly will work.
\begin{code}
pprFCall call@(CCall (CCallSpec op_str cconv safety is_asm)) uniq args results vol_regs
pprFCall call@(CCall (CCallSpec target cconv safety)) uniq args results vol_regs
= vcat [
char '{',
declare_local_vars, -- local var for *result*
vcat local_arg_decls,
pp_save_context,
process_casm local_vars pp_non_void_args casm_str,
process_casm local_vars pp_non_void_args call_str,
pp_restore_context,
assign_results,
char '}'
......@@ -814,16 +814,17 @@ pprFCall call@(CCall (CCallSpec op_str cconv safety is_asm)) uniq args results v
(declare_local_vars, local_vars, assign_results)
= ppr_casm_results non_void_results
casm_str = if is_asm then _UNPK_ asm_str else ccall_str
StaticTarget asm_str = op_str -- Must be static if it's a casm
call_str = case target of
CasmTarget str -> _UNPK_ str
StaticTarget fn -> mk_ccall_str (pprCLabelString fn) ccall_args
DynamicTarget -> mk_ccall_str dyn_fun (tail ccall_args)
-- Remainder only used for ccall
fun_name = case op_str of
DynamicTarget -> parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr uniq) <> text "%0")
StaticTarget st -> pprCLabelString st
ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
dyn_fun = parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr uniq) <> text "%0")
ccall_str = showSDoc
-- Remainder only used for ccall
mk_ccall_str fun_name ccall_fun_args = showSDoc
(hcat [
if null non_void_results
then empty
......@@ -832,11 +833,6 @@ pprFCall call@(CCall (CCallSpec op_str cconv safety is_asm)) uniq args results v
hcat (punctuate comma ccall_fun_args),
text "));"
])
ccall_fun_args | isDynamicTarget op_str = tail ccall_args
| otherwise = ccall_args
ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
\end{code}
If the argument is a heap object, we need to reach inside and pull out
......
......@@ -49,7 +49,7 @@ import Id ( Id, idType, isId,
import VarSet
import Literal ( isLitLitLit, litSize )
import PrimOp ( primOpIsDupable, primOpOutOfLine )
import ForeignCall ( ForeignCall(..), ccallIsCasm )
import ForeignCall ( okToExposeFCall )
import IdInfo ( InlinePragInfo(..), OccInfo(..), GlobalIdDetails(..),
isNeverInlinePrag
)
......@@ -490,10 +490,6 @@ okToUnfoldInHiFile e = opt_UnfoldCasms || go e
not (any isLitLitLit [ lit | (LitAlt lit, _, _) <- alts ])
go (Note _ body) = go body
go (Type _) = True
-- ok to unfold a PrimOp as long as it's not a _casm_
okToExposeFCall (CCall cc) = not (ccallIsCasm cc)
okToExposeFCall other = True
\end{code}
......
......@@ -26,7 +26,7 @@ import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, CC
import DataCon ( splitProductType_maybe, dataConSourceArity, dataConWrapId )
import ForeignCall ( ForeignCall, CCallTarget(..) )
import Type ( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys,
splitTyConApp_maybe, tyVarsOfType, mkForAllTys,
splitTyConApp_maybe, tyVarsOfType, mkForAllTys, isPrimitiveType,
isNewType, repType, isUnLiftedType, mkFunTy, mkTyConApp,
Type
)
......@@ -96,7 +96,9 @@ dsCCall lbl args may_gc is_asm result_ty
boxResult [] result_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
getUniqueDs `thenDs` \ uniq ->
let
the_fcall = CCall (CCallSpec (StaticTarget lbl) CCallConv may_gc is_asm)
target | is_asm = CasmTarget lbl
| otherwise = StaticTarget lbl
the_fcall = CCall (CCallSpec target CCallConv may_gc)
the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
in
returnDs (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
......@@ -134,8 +136,8 @@ unboxArg :: CoreExpr -- The supplied argument
-- where W is a CoreExpr that probably mentions x#
unboxArg arg
-- Unlifted types: nothing to unbox
| isUnLiftedType arg_ty
-- Primtive types: nothing to unbox
| isPrimitiveType arg_ty
= returnDs (arg, \body -> body)
-- Newtypes
......@@ -293,7 +295,7 @@ resultWrapper :: Type
CoreExpr -> CoreExpr) -- Wrapper for the result
resultWrapper result_ty
-- Base case 1: primitive types
| isUnLiftedType result_ty
| isPrimitiveType result_ty
= (Just result_ty, \e -> e)
-- Base case 1: the unit type ()
......
......@@ -15,8 +15,7 @@ import CoreSyn
import DsCCall ( dsCCall, mkFCall, boxResult, unboxArg, resultWrapper )
import DsMonad
import HsSyn ( ExtName(..), ForeignDecl(..), isDynamicExtName, ForKind(..) )
import HsDecls ( extNameStatic )
import HsSyn ( ForeignDecl(..), FoExport(..), FoImport(..) )
import TcHsSyn ( TypecheckedForeignDecl )
import CoreUtils ( exprType, mkInlineMe )
import Id ( Id, idType, idName, mkVanillaGlobal, mkSysLocal,
......@@ -35,9 +34,10 @@ import Type ( repType, splitTyConApp_maybe,
)
import ForeignCall ( ForeignCall(..), CCallSpec(..),
Safety(..), playSafe,
CCallTarget(..), dynamicTarget,
CExportSpec(..),
CCallConv(..), ccallConvToInt
)
import CStrings ( CLabelString )
import TysWiredIn ( unitTy, addrTy, stablePtrTyCon )
import TysPrim ( addrPrimTy )
import PrelNames ( hasKey, ioTyConKey, deRefStablePtrName, newStablePtrName,
......@@ -75,36 +75,25 @@ dsForeigns :: Module
, SDoc -- C stubs to use when calling
-- "foreign exported" functions.
)
dsForeigns mod_name fos = foldlDs combine ([], [], empty, empty) fos
dsForeigns mod_name fos
= foldlDs combine ([], [], empty, empty) fos
where
combine (acc_feb, acc_f, acc_h, acc_c) fo@(ForeignDecl i imp_exp _ ext_nm cconv _)
| isForeignImport = -- foreign import (dynamic)?
dsFImport i (idType i) uns ext_nm cconv `thenDs` \ bs ->
returnDs (acc_feb, bs ++ acc_f, acc_h, acc_c)
| isForeignLabel =
dsFLabel i (idType i) ext_nm `thenDs` \ b ->
returnDs (acc_feb, b:acc_f, acc_h, acc_c)
| isDynamicExtName ext_nm =
dsFExportDynamic i (idType i) mod_name ext_nm cconv `thenDs` \ (feb,bs,h,c) ->
returnDs (feb:acc_feb, bs ++ acc_f, h $$ acc_h, c $$ acc_c)
| otherwise = -- foreign export
dsFExport i (idType i) mod_name ext_nm cconv False `thenDs` \ (feb,fe,h,c) ->
returnDs (feb:acc_feb, fe:acc_f, h $$ acc_h, c $$ acc_c)
where
isForeignImport =
case imp_exp of
FoImport _ -> True
_ -> False
isForeignLabel =
case imp_exp of
FoLabel -> True
_ -> False
FoImport uns = imp_exp
combine (acc_feb, acc_f, acc_h, acc_c) (ForeignImport id _ spec _)
= dsFImport mod_name id spec `thenDs` \ (bs, h, c) ->
returnDs (acc_feb, bs ++ acc_f, h $$ acc_h, c $$ acc_c)
combine (acc_feb, acc_f, acc_h, acc_c) (ForeignExport id _ (CExport (CExportStatic ext_nm cconv)) _)
= dsFExport mod_name id (idType id) ext_nm cconv False `thenDs` \ (feb, b, h, c) ->
returnDs (feb:acc_feb, b : acc_f, h $$ acc_h, c $$ acc_c)
\end{code}
%************************************************************************
%* *
\subsection{Foreign import}
%* *
%************************************************************************
Desugaring foreign imports is just the matter of creating a binding
that on its RHS unboxes its arguments, performs the external call
(using the @CCallOp@ primop), before boxing the result up and returning it.
......@@ -125,14 +114,33 @@ because it exposes the boxing to the call site.
\begin{code}
dsFImport :: Id
-> Type -- Type of foreign import.
-> Safety -- Whether can re-enter the Haskell RTS, do GC etc
-> ExtName
-> CCallConv
-> DsM [Binding]
dsFImport fn_id ty safety ext_name cconv
dsFImport :: Module
-> Id
-> FoImport
-> DsM ([Binding], SDoc, SDoc)
dsFImport mod_name lbl_id (LblImport ext_nm)
= ASSERT(fromJust res_ty == addrPrimTy) -- typechecker ensures this
returnDs ([(lbl_id, rhs)], empty, empty)
where
(res_ty, fo_rhs) = resultWrapper (idType lbl_id)
rhs = fo_rhs (mkLit (MachLabel ext_nm))
dsFImport mod_name fn_id (CImport spec) = dsFCall mod_name fn_id (CCall spec)
dsFImport mod_name fn_id (DNImport spec) = dsFCall mod_name fn_id (DNCall spec)
dsFImport mod_name fn_id (CDynImport cconv) = dsFExportDynamic mod_name fn_id cconv
\end{code}
%************************************************************************
%* *
\subsection{Foreign calls}
%* *
%************************************************************************
\begin{code}
dsFCall mod_Name fn_id fcall
= let
ty = idType fn_id
(tvs, fun_ty) = splitForAllTys ty
(arg_tys, io_res_ty) = splitFunTys fun_ty
in
......@@ -145,22 +153,17 @@ dsFImport fn_id ty safety ext_name cconv
-- These are the ids we pass to boxResult, which are used to decide
-- whether to touch# an argument after the call (used to keep
-- ForeignObj#s live across a 'safe' foreign import).
maybe_arg_ids | playSafe safety = work_arg_ids
| otherwise = []
maybe_arg_ids | unsafe_call fcall = work_arg_ids
| otherwise = []
in
boxResult maybe_arg_ids io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
getUniqueDs `thenDs` \ ccall_uniq ->
getUniqueDs `thenDs` \ work_uniq ->
let
lbl = case ext_name of
Dynamic -> dynamicTarget
ExtName fs _ -> StaticTarget fs
-- Build the worker
worker_ty = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
the_ccall = CCall (CCallSpec lbl cconv safety False)
the_ccall_app = mkFCall ccall_uniq the_ccall val_args ccall_result_ty
the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty
work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app)
work_id = mkSysLocal SLIT("$wccall") work_uniq worker_ty
......@@ -169,20 +172,18 @@ dsFImport fn_id ty safety ext_name cconv
wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
wrap_rhs = mkInlineMe (mkLams (tvs ++ args) wrapper_body)
in
returnDs [(work_id, work_rhs), (fn_id, wrap_rhs)]
returnDs ([(work_id, work_rhs), (fn_id, wrap_rhs)], empty, empty)
unsafe_call (CCall (CCallSpec _ _ safety)) = playSafe safety
unsafe_call (DNCall _) = False
\end{code}
Foreign labels
\begin{code}
dsFLabel :: Id -> Type -> ExtName -> DsM Binding
dsFLabel nm ty ext_name =
ASSERT(fromJust res_ty == addrPrimTy) -- typechecker ensures this
returnDs (nm, fo_rhs (mkLit (MachLabel enm)))
where
(res_ty, fo_rhs) = resultWrapper ty
enm = extNameStatic ext_name
\end{code}
%************************************************************************
%* *
\subsection{Foreign export}
%* *
%************************************************************************
The function that does most of the work for `@foreign export@' declarations.
(see below for the boilerplate code a `@foreign export@' declaration expands
......@@ -196,19 +197,21 @@ For each `@foreign export foo@' in a module M we generate:
the user-written Haskell function `@M.foo@'.
\begin{code}
dsFExport :: Id
-> Type -- Type of foreign export.
-> Module
-> ExtName
dsFExport :: Module
-> Id -- Either the exported Id,
-- or the foreign-export-dynamic constructor
-> Type -- The type of the thing callable from C
-> CLabelString -- The name to export to C land
-> CCallConv
-> Bool -- True => invoke IO action that's hanging off
-- the first argument's stable pointer
-> Bool -- True => foreign export dynamic
-- so invoke IO action that's hanging off
-- the first argument's stable pointer
-> DsM ( Id -- The foreign-exported Id
, Binding
, SDoc
, SDoc
)
dsFExport fn_id ty mod_name ext_name cconv isDyn
dsFExport mod_name fn_id ty ext_name cconv isDyn
= -- BUILD THE returnIO WRAPPER, if necessary
-- Look at the result type of the exported function, orig_res_ty
-- If it's IO t, return (\x.x, IO t, t)
......@@ -282,20 +285,19 @@ dsFExport fn_id ty mod_name ext_name cconv isDyn
the_app = getFun_wrapper (return_io_wrapper (mkVarApps (Var i) (tvs ++ fe_args)))
the_body = mkLams (tvs ++ wrapper_args) the_app
c_nm = extNameStatic ext_name
(h_stub, c_stub) = fexportEntry (moduleUserString mod)
c_nm f_helper_glob
wrapper_arg_tys res_ty cconv isDyn
ext_name f_helper_glob
wrapper_arg_tys res_ty cconv isDyn
in
returnDs (f_helper_glob, (f_helper_glob, the_body), h_stub, c_stub)
where
(tvs,sans_foralls) = splitForAllTys ty
(fe_arg_tys', orig_res_ty) = splitFunTys sans_foralls
(tvs,sans_foralls) = splitForAllTys ty
(fe_arg_tys', orig_res_ty) = splitFunTys sans_foralls
(_, stbl_ptr_ty') = splitForAllTys stbl_ptr_ty
(_, stbl_ptr_to_ty) = splitAppTy stbl_ptr_ty'
(_, stbl_ptr_ty') = splitForAllTys stbl_ptr_ty
(_, stbl_ptr_to_ty) = splitAppTy stbl_ptr_ty'
fe_arg_tys | isDyn = tail fe_arg_tys'
| otherwise = fe_arg_tys'
......@@ -327,23 +329,19 @@ foreign export "f_helper" f_helper :: StablePtr (Addr -> Int -> IO Int) -> Addr
\end{verbatim}
\begin{code}
dsFExportDynamic :: Id
-> Type -- Type of foreign export.
-> Module
-> ExtName
dsFExportDynamic :: Module
-> Id
-> CCallConv
-> DsM (Id, [Binding], SDoc, SDoc)
dsFExportDynamic i ty mod_name ext_name cconv =
newSysLocalDs ty `thenDs` \ fe_id ->
-> DsM ([Binding], SDoc, SDoc)
dsFExportDynamic mod_name id cconv
= newSysLocalDs ty `thenDs` \ fe_id ->
let
-- hack: need to get at the name of the C stub we're about to generate.
fe_nm = moduleUserString mod_name ++ "_" ++ toCName fe_id
fe_ext_name = ExtName (_PK_ fe_nm) Nothing
fe_nm = _PK_ (moduleUserString mod_name ++ "_" ++ toCName fe_id)
in
dsFExport i export_ty mod_name fe_ext_name cconv True
`thenDs` \ (feb, fe, h_code, c_code) ->
newSysLocalDs arg_ty `thenDs` \ cback ->
dsLookupGlobalValue newStablePtrName `thenDs` \ newStablePtrId ->
dsFExport mod_name id export_ty fe_nm cconv True `thenDs` \ (feb, fe, h_code, c_code) ->
newSysLocalDs arg_ty `thenDs` \ cback ->
dsLookupGlobalValue newStablePtrName `thenDs` \ newStablePtrId ->
let
mk_stbl_ptr_app = mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
in
......@@ -367,7 +365,7 @@ dsFExportDynamic i ty mod_name ext_name cconv =
-}
adj_args = [ mkIntLitInt (ccallConvToInt cconv)
, Var stbl_value
, mkLit (MachLabel (_PK_ fe_nm))
, mkLit (MachLabel fe_nm)
]
-- name of external entry point providing these services.
-- (probably in the RTS.)
......@@ -382,13 +380,14 @@ dsFExportDynamic i ty mod_name ext_name cconv =
io_app = mkLams tvs $
mkLams [cback] $
stbl_app ccall_io_adj res_ty
fed = (i `setInlinePragma` neverInlinePrag, io_app)
fed = (id `setInlinePragma` neverInlinePrag, io_app)
-- Never inline the f.e.d. function, because the litlit
-- might not be in scope in other modules.
in
returnDs (feb, [fed, fe], h_code, c_code)
returnDs ([fed, fe], h_code, c_code)
where
ty = idType id
(tvs,sans_foralls) = splitForAllTys ty
([arg_ty], io_res_ty) = splitFunTys sans_foralls
Just (ioTyCon, [res_ty]) = splitTyConApp_maybe io_res_ty
......
......@@ -9,12 +9,13 @@ Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@,
\begin{code}
module HsDecls (
HsDecl(..), TyClDecl(..), InstDecl(..), RuleDecl(..), RuleBndr(..),
DefaultDecl(..), ForeignDecl(..), ForKind(..),
ExtName(..), isDynamicExtName, extNameStatic,
DefaultDecl(..),
ForeignDecl(..), FoImport(..), FoExport(..), FoType(..),
ConDecl(..), ConDetails(..),
BangType(..), getBangType, getBangStrictness, unbangedType,
DeprecDecl(..), DeprecTxt,
hsDeclName, instDeclName, tyClDeclName, tyClDeclNames, tyClDeclSysNames,
hsDeclName, instDeclName,
tyClDeclName, tyClDeclNames, tyClDeclSysNames, tyClDeclTyVars,
isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls,
mkClassDeclSysNames, isIfaceRuleDecl, ifaceRuleDeclName,
getClassDeclSysNames, conDetailsTys
......@@ -33,14 +34,13 @@ import HsCore ( UfExpr, UfBinder, HsIdInfo, pprHsIdInfo,
import CoreSyn ( CoreRule(..) )
import BasicTypes ( NewOrData(..) )
import Demand ( StrictnessMark(..) )
import ForeignCall ( CCallConv )
import ForeignCall ( CExportSpec, CCallSpec, DNCallSpec, CCallConv )
-- others:
import ForeignCall ( Safety )
import Name ( NamedThing )
import FunDeps ( pprFundeps )
import Class ( FunDep, DefMeth(..) )
import CStrings ( CLabelString, pprCLabelString )
import CStrings ( CLabelString )
import Outputable
import SrcLoc ( SrcLoc )
\end{code}
......@@ -82,10 +82,10 @@ data HsDecl name pat
hsDeclName :: (NamedThing name, Outputable name, Outputable pat)
=> HsDecl name pat -> name
#endif
hsDeclName (TyClD decl) = tyClDeclName decl
hsDeclName (InstD decl) = instDeclName decl
hsDeclName (ForD (ForeignDecl name _ _ _ _ _)) = name
hsDeclName (FixD (FixitySig name _ _)) = name
hsDeclName (TyClD decl) = tyClDeclName decl
hsDeclName (InstD decl) = instDeclName decl
hsDeclName (ForD decl) = forDeclName decl
hsDeclName (FixD (FixitySig name _ _)) = name
-- Others don't make sense
#ifdef DEBUG
hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x)
......@@ -249,13 +249,22 @@ Interface file code:
\begin{code}
-- TyClDecls are precisely the kind of declarations that can
-- appear in interface files; or (internally) in GHC's interface
-- for a module. That's why (despite the misnomer) IfaceSig and ForeignType
-- are both in TyClDecl
data TyClDecl name pat
= IfaceSig { tcdName :: name, -- It may seem odd to classify an interface-file signature
tcdType :: HsType name, -- as a 'TyClDecl', but it's very convenient. These three
tcdIdInfo :: [HsIdInfo name], -- are the kind that appear in interface files.
tcdType :: HsType name, -- as a 'TyClDecl', but it's very convenient.
tcdIdInfo :: [HsIdInfo name],
tcdLoc :: SrcLoc
}
| ForeignType { tcdName :: name, -- See remarks about IfaceSig above
tcdFoType :: FoType,
tcdLoc :: SrcLoc }
| TyData { tcdND :: NewOrData,
tcdCtxt :: HsContext name, -- context
tcdName :: name, -- type constructor
......@@ -321,8 +330,9 @@ tyClDeclNames :: Eq name => TyClDecl name pat -> [(name, SrcLoc)]
-- For record fields, the first one counts as the SrcLoc
-- We use the equality to filter out duplicate field names
tyClDeclNames (TySynonym {tcdName = name, tcdLoc = loc}) = [(name,loc)]
tyClDeclNames (IfaceSig {tcdName = name, tcdLoc = loc}) = [(name,loc)]
tyClDeclNames (TySynonym {tcdName = name, tcdLoc = loc}) = [(name,loc)]
tyClDeclNames (IfaceSig {tcdName = name, tcdLoc = loc}) = [(name,loc)]
tyClDeclNames (ForeignType {tcdName = name, tcdLoc = loc}) = [(name,loc)]
tyClDeclNames (ClassDecl {tcdName = cls_name, tcdSigs = sigs, tcdLoc = loc})
= (cls_name,loc) : [(n,loc) | ClassOpSig n _ _ loc <- sigs]
......@@ -331,6 +341,13 @@ tyClDeclNames (TyData {tcdName = tc_name, tcdCons = cons, tcdLoc = loc})
= (tc_name,loc) : conDeclsNames cons
tyClDeclTyVars (TySynonym {tcdTyVars = tvs}) = tvs
tyClDeclTyVars (TyData {tcdTyVars = tvs}) = tvs
tyClDeclTyVars (ClassDecl {tcdTyVars = tvs}) = tvs
tyClDeclTyVars (ForeignType {}) = []
tyClDeclTyVars (IfaceSig {}) = []
--------------------------------
-- The "system names" are extra implicit names *bound* by the decl.
-- They are kept in a list rather than a tuple
......@@ -373,6 +390,10 @@ instance (NamedThing name, Ord name) => Eq (TyClDecl name pat) where
tcdType d1 == tcdType d2 &&
tcdIdInfo d1 == tcdIdInfo d2
(==) d1@(ForeignType {}) d2@(ForeignType {})
= tcdName d1 == tcdName d2 &&
tcdFoType d1 == tcdFoType d2
(==) d1@(TyData {}) d2@(TyData {})
= tcdName d1 == tcdName d2 &&
tcdND d1 == tcdND d2 &&
......@@ -433,6 +454,9 @@ instance (NamedThing name, Outputable name, Outputable pat)
ppr (IfaceSig {tcdName = var, tcdType = ty, tcdIdInfo = info})
= hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info]
ppr (ForeignType {tcdName = tycon})
= hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
ppr (TySynonym {tcdName = tycon, tcdTyVars = tyvars, tcdSynRhs = mono_ty})
= hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars <+> equals)
4 (ppr mono_ty)
......@@ -670,55 +694,46 @@ instance (Outputable name)
%************************************************************************
\begin{code}
data ForeignDecl name =
ForeignDecl
name
ForKind
(HsType name)
ExtName
CCallConv
SrcLoc
instance (Outputable name)
=> Outputable (ForeignDecl name) where
ppr (ForeignDecl nm imp_exp ty ext_name cconv src_loc)
= ptext SLIT("foreign") <+> ppr_imp_exp <+> ppr cconv <+>
ppr ext_name <+> ppr_unsafe <+> ppr nm <+> dcolon <+> ppr ty
where
(ppr_imp_exp, ppr_unsafe) =
case imp_exp of
FoLabel -> (ptext SLIT("label"), empty)
FoExport -> (ptext SLIT("export"), empty)
FoImport us -> (ptext SLIT("import"), ppr us)
data ForKind
= FoLabel
| FoExport
| FoImport Safety
data ExtName
= Dynamic
| ExtName CLabelString -- The external name of the foreign thing,
(Maybe CLabelString) -- and optionally its DLL or module name
-- Both of these are completely unencoded;
-- we just print them as they are
isDynamicExtName :: ExtName -> Bool
isDynamicExtName Dynamic = True
isDynamicExtName _ = False
extNameStatic :: ExtName -> CLabelString
extNameStatic (ExtName f _) = f
extNameStatic Dynamic = panic "staticExtName: Dynamic - shouldn't ever happen."
instance Outputable ExtName where
ppr Dynamic = ptext SLIT("dynamic")
ppr (ExtName nm mb_mod) =
case mb_mod of { Nothing -> empty; Just m -> doubleQuotes (ptext m) } <+>
doubleQuotes (pprCLabelString nm)
data ForeignDecl name
= ForeignImport name (HsType name) FoImport SrcLoc
| ForeignExport name (HsType name) FoExport SrcLoc
forDeclName (ForeignImport n _ _ _) = n
forDeclName (ForeignExport n _ _ _) = n
data FoImport
= LblImport CLabelString -- foreign label
| CImport CCallSpec -- foreign import
| CDynImport CCallConv -- foreign export dynamic
| DNImport DNCallSpec -- foreign import dotnet
data FoExport = CExport CExportSpec
data FoType = DNType -- In due course we'll add subtype stuff
deriving( Eq ) -- Used for equality instance for TyClDecl
instance Outputable name => Outputable (ForeignDecl name) where
ppr (ForeignImport nm ty (LblImport lbl) src_loc)
= ptext SLIT("foreign label") <+> ppr lbl <+> ppr nm <+> dcolon <+> ppr ty
ppr (ForeignImport nm ty decl src_loc)
= ptext SLIT("foreign import") <+> ppr decl <+> ppr nm <+> dcolon <+> ppr ty
ppr (ForeignExport nm ty decl src_loc)
= ptext SLIT("foreign export") <+> ppr decl <+> ppr nm <+> dcolon <+> ppr ty
instance Outputable FoImport where
ppr (CImport d) = ppr d
ppr (CDynImport conv) = text "dynamic" <+> ppr conv
ppr (DNImport d) = ptext SLIT("dotnet") <+> ppr d
ppr (LblImport l) = ptext SLIT("label") <+> ppr l
instance Outputable FoExport where
ppr (CExport d) = ppr d
instance Outputable FoType where
ppr DNType = ptext SLIT("type dotnet")
\end{code}