hdirect-0.21.0: src/CodeGen.lhs
%
% (c) The Foo Project, University of Glasgow, 1998
%
% @(#) $Docid: Mar. 31th 2003 08:52 Sigbjorn Finne $
% @(#) $Contactid: sof@galois.com $
%
Toplevel module for converting IDL into abstract Haskell code,
ready for dumping out to a file.
\begin{code}
module CodeGen ( codeGen ) where
import MarshallUtils
import MarshallStruct
import MarshallEnum
import MarshallType
import MarshallMethod
import MarshallUnion
import MarshallAbstract ( marshallAbstract )
import MarshallServ
import MarshallCore
import MarshallFun
import MarshallJNI
import MarshallJServ
import Skeleton
import qualified CustomAttributes
import BasicTypes
import Literal
import AbstractH hiding (Type(..), Expr(..),CaseAlt(..))
import qualified AbstractH as Haskell ( HDecl(..),
TyDecl(..),
ConDecl(..),
BangType(..)
)
import AbsHUtils
import MkImport ( mkImportLists )
import LibUtils
import Opts ( optGenHeader, optNoExportList,
optOneModulePerInterface, optServer,
optUnparamedInterfacePointers,
optSubtypedInterfacePointers, optExportAbstractly,
optDualVtbl, optDon'tGenBinaryComInterfaces,
optSkel, optIgnoreDispInterfaces, optNoLibIds,
optIgnoreSourceIfaces, optNoEnumMagic, optHaskellToC,
optJNI, optCorba, optIgnoreMethsUpto, optUseStdDispatch,
optOutputHTo, optEnumsAsFlags, optGenNumInstance, optGenBitsInstance
)
import PpAbstractH ( ppType, showAbstractH )
import PpCore ( showCore, ppDecl )
import CgMonad
import CoreIDL
import CoreUtils
import Attribute
import List ( partition, intersperse, isPrefixOf )
import Utils ( dropSuffix, trace, basename, split,
splitdir, prefixDir, notNull
)
import Maybe ( mapMaybe, isJust )
import Monad ( when )
import Env
\end{code}
External interface, convert a set of toplevel IDL
declarations into their Haskell form.
A translation unit can at the toplevel consist of:
- one or more modules
- one or more libraries
- one or more (disp)interfaces/coclasses.
IDL grouping declarations map onto Haskell modules as follows:
- modules and libraries get their own Haskell module.
- optionally, each (disp)interface/coclass can be put into
a file of their own. (doing this eases the problem of
namespace clashes, relying instead on the Haskell module
system to operate satisfactorily..)
\begin{code}
codeGen :: (Either String String, Maybe String)
{- User-supplied output name -}
-> Env String [(Result, [Param])]
{- environment carrying type isomorphic methods info -}
-> Env String (Maybe Id)
{- environment containing ifaces that should be ignored -}
-> [Decl]
-> ( [(String, Decl)] {- possible header file output -}
, [(String, Bool, [HTopDecl])] {- Haskell output -}
)
codeGen (o_fname, mname) iso_env iface_env decls =
( generateHeader top_module_name decls
, (\ x -> if optSkel then x ++ cgSkeleton decls else x) $
liftOut (map (cGen iso_env iface_env) modules)
)
where
liftOut [] = []
liftOut (m@(nm, has_struct, ds) : ms) =
case break isHMod ds of
(ls,[x,HMod md@(HModule nm1 _ _ _ _)]) ->
(nm, has_struct, ls ++ [x]) :
(nm1 ++ ".hs", False, [HMod md]) : liftOut ms
_ -> m : liftOut ms
isHMod (HMod _) = True
isHMod _ = False
-- The set of modules to generate. If there's any leftovers at the
-- top (i.e., stuff that appear outside a module/library/interface etc. grouping),
-- we put these bits into the top_module. In the one-module-per-interface
-- case, this means that for typedefs that appear inside interfaces will
-- be lifted out and be generated with the outermost module (arguably they
-- shouldn't be lifted out, but that's how things are organised at the moment.)
modules =
case mods_and_libs of
[_] -> [one_module] -- make sure we emit everything.
_ ->
case rest of
[] -> mods_and_libs
_ -> top_module : mods_and_libs
toStdOut =
case o_fname of
Right "-" -> True
_ -> False
-- use output filename to generate a plausible looking
-- Haskell module name.
(top_module_name, output_fname) =
case mname of
Just x -> (x, snd ofnames)
_ -> ofnames
where
ofnames =
case o_fname of
Right "-" ->
case mods_and_libs of
((_,m,_):_) -> (m, "-")
_ -> ("Anon", "-")
Left x -> let
(_,base) = splitdir x
y = mkHaskellTyConName (dropSuffix base)
in
(y, x)
Right x ->
case mods_and_libs of
[(_,m,_)] -> let
(dir,_) = splitdir x
in (m, prefixDir dir (m ++ ".hs"))
_ -> (mkModName x, x)
mkModName x = mkHaskellTyConName (basename (dropSuffix x))
top_module = ( output_fname
, top_module_name
, mkTopModule (mkId top_module_name
top_module_name
Nothing
[{-no attrs-}])
rest
)
one_module = ( output_fname
, top_module_name
, mkTopModule (mkId top_module_name
top_module_name
Nothing
[{-no attrs-}])
flattened_decls
)
-- Hoist out some of these. Currently they all have to be at the top,
-- we don't scan through the whole file looking for them.
mkTopModule i (d@(HsLiteral _) : xs) = d : mkTopModule i xs
mkTopModule i (d@(CInclude _) : xs) = d : mkTopModule i xs
mkTopModule i (d@(CLiteral _) : xs) = d : mkTopModule i xs
-- delayed addition of the attributes for the module itself.
mkTopModule i ds@(d@Module{} : _) = [Module i{idAttributes=idAttributes (declId d)} ds]
mkTopModule i ds@(d@Library{} : _) = [Module i{idAttributes=idAttributes (declId d)} ds]
mkTopModule i ds = [Module i ds]
mods_and_libs = map ( \ d -> let (x,y) = mkModuleLibName d in (x, y, [d])) mods_and_libs'
(mods_and_libs', rest) = partition inSeparateHaskellModule flattened_decls
flattened_decls = flattenDecls decls
mkModuleLibName d
| toStdOut = ("-", hnm)
| otherwise = (hnm ++ ".hs", hnm)
where
hnm = mkHaskellTyConName nm
nm_raw = idName (declId d)
nm
| optServer = nm_raw ++ "Proxy"
| otherwise = nm_raw
\end{code}
\begin{code}
cGen :: Env String [(Result, [Param])]
-> Env String (Maybe Id)
-> (String, String, [Decl])
-> (String, Bool, [HTopDecl])
cGen iso_env iface_env (oname, mod_name, ds) = (oname, flg, ds')
where
(ds',flg) = foldr mkHTop ([],False) ds
mkHTop d (acc, has_structs) =
case d of
Library i ms ->
case (runCgM iso_env iface_env (withDeclName (idName i) (cgLibrary i ms))) of
(decl, expo, imps, flg1, has_prim) ->
let qual_imps = mkImportLists mod_name (getHsImports i) [decl]
real_imps = qual_imps ++ imps
in
(modDecl i has_prim [decl] real_imps expo : acc, has_structs || flg1)
DispInterface i _ _ _ ->
case (runCgM iso_env iface_env (withIfaceDeclName (idName i) (cgDecl d))) of
(decl, expo, imps, flg1, has_prim) ->
let qual_imps = mkImportLists mod_name (getHsImports i) [decl]
real_imps = qual_imps ++ imps
in
(modDecl i has_prim [decl] real_imps expo : acc, has_structs || flg1)
Interface i is_ref inherit _
| not is_ref ->
case (runCgM iso_env iface_env (withIfaceDeclName (idName i) (cgDecl d))) of
(decl, expo, imps, flg1, has_prim) ->
let qual_imps = mkImportLists mod_name (getHsImports i) [decl]
real_imps = qual_imps ++ imps
attrs = idAttributes i
iface_deps = filterAttributes attrs ["depender"]
new_attrs = filterOutAttributes attrs ["depender"]
i' = i{idAttributes=new_attrs}
(acc', has_structs')
| not optOneModulePerInterface || null iface_deps = (acc, has_structs)
| otherwise =
case mkHTop (Interface i' False inherit []) (acc, has_structs) of
(HMod (HModule nm a b c d1) : ls, e) ->
(HMod (HModule (nm ++ "Ty") a b c d1) : ls , e)
x -> x
in
(modDecl i has_prim [decl] real_imps expo : acc', has_structs' || flg1)
| otherwise -> (acc, has_structs)
CoClass{} ->
case (runCgM iso_env iface_env (cgDecl d)) of
(decl, expo, imps, flg1, has_prim) ->
let qual_imps = mkImportLists mod_name (getHsImports (declId d)) [decl]
real_imps = qual_imps ++ imps
in
if isEmptyDecl decl then
(acc, has_structs)
else
(hModule mod_name
has_prim
(map (\ (x,_,y) -> hExport x y) expo)
(map (\ (x,y,z) -> hImport x y z) real_imps)
decl : acc, has_structs || flg1)
Module i ms ->
case (runCgM iso_env iface_env (withDeclName (idName i) (cgModule i ms))) of
(decl, expo,imps,flg1, has_prim) ->
let qual_imps = mkImportLists mod_name (getHsImports i) [decl]
real_imps = qual_imps ++ imps
in
( modDecl (i{idName=mod_name}) has_prim [decl] real_imps expo : acc
, has_structs || flg1
)
HsLiteral s -> (hMeta s : acc, has_structs)
CLiteral s -> (cMeta s : acc, has_structs)
CInclude s -> (hInclude s : acc, has_structs)
_ -> error ("Odd decl: " ++ showCore (ppDecl d))
modDecl _ mflg decls imps expo
| optNoExportList =
hModule mod_name mflg
(map (\ (x,_,y) -> hExport x y) $ filter (\ (_,x,_) -> x) expo)
(map (\ (x,y,z) -> hImport x y z) imps)
(andDecls decls)
| otherwise =
hModule mod_name mflg
(map (\ (x,_,y) -> hExport x y) expo)
(map (\ (x,y,z) -> hImport x y z) imps)
(andDecls decls)
\end{code}
From the .idl input, we optionally generate C header file information. This is
useful when the master copy of the .h file is the .idl specification (or, you
don't have the header file already available.)
\begin{code}
generateHeader :: String -> [Decl] -> [(String, Decl)]
generateHeader o_fname decls
| not optGenHeader = []
| otherwise =
case optOutputHTo of
(x:_) ->
let
nm = dropSuffix x
in
[(oname, Module (mkId nm nm Nothing []) decls)]
_ ->
case (concatMap mkHeaderDecls decls) of
[] -> [(oname, Module (mkId oname oname Nothing []) decls)]
[(_,s)] -> [(oname, s)]
ls -> ls
where
oname =
case optOutputHTo of
(x:_) -> x
_ ->
case o_fname of
"-" -> "-"
_ -> dropSuffix o_fname ++ ".h"
mkHeaderNm i = mkHaskellTyConName (idName i) ++ ".h"
mkHeaderDecls d =
case d of
Module i _ -> [(mkHeaderNm i, d)]
Interface i _ _ _ -> [(mkHeaderNm i, d)]
DispInterface i _ _ _ -> [(mkHeaderNm i, d)]
Library i _ -> [(mkHeaderNm i, d)]
_ -> []
\end{code}
Generating code for the various Core IDL declarations:
\begin{code}
cgDecl :: Decl -> CgM HDecl
cgDecl d =
case d of
Typedef n t _ -> cgTypedef n t
Constant i t o_t e -> cgConstant i t o_t e
Interface i _ inherit decls ->
withIfaceInherit (map fst inherit) $
hoistInClass (idName i) $ \ mb_cls -> do
cls_d <-
{-
Check to see if we should include a CLSID declaration
as well. Do this in the case where we've got
interface _A { ... }; coclass A { interface _A; };
and A has the only use of _A. Useful in one-module-per-interface mode,
as it avoids creating a (v simple) module for the coclass.
-}
case mb_cls of
Nothing -> return emptyDecl
Just ci
| notNull deps -> return emptyDecl
| otherwise -> do
let ci'
| idName i `isPrefixOf` idName ci = ci{idName=idName i}
| otherwise = ci
ud <- setInterfaceFlag (ComIDispatch False) (uuidDecl ci' [] Clsid)
return (infoHeader (CoClass ci' [CoClassInterface i Nothing]) `andDecl` ud)
forClient <- getClientFlag
let is_source = hasSourceAttribute (idAttributes i)
setSourceIfaceFlag is_source $ do
dserv <-
if (is_source && optIgnoreSourceIfaces) then
return emptyDecl
else
if (is_source && forClient) || (not forClient && not is_source) then
marshallServ i inherit decls
else
cgInterface i inherit decls
return (cls_d `andDecl` dserv)
where
deps = filterAttributes (idAttributes i) ["depender"]
Method i cc res ps offs -> do
forClient <- getClientFlag
is_source <- getSourceIfaceFlag
if (is_source && forClient) || (not forClient && not is_source) then do
k <- getInterfaceFlag
case k of
StdFFI -> getDeclName $ \ nm ->
marshallFun (Just nm) i (FunTy cc res ps)
_ | optJNI -> cgJServMethod i res ps
| otherwise -> do
isInDisp <- isInDispInterface
cgServMethod i res ps is_source (optUseStdDispatch && isInDisp)
else
if optJNI then
cgJNIMethod i res ps
else
cgMethod i cc res ps offs Nothing
Property i ty _ s g -> cgProperty i ty s g
HsLiteral str -> return (Haskell str)
CLiteral str -> return (CCode str)
CInclude fname -> return (Include fname)
DispInterface i ii ps ms -> cgDispInterface i ii ps ms
CoClass i mems -> cgCoClass i mems
Library i decls -> cgLibrary i decls
Module i ds -> cgModule i ds
_ -> return emptyDecl
\end{code}
%
%
<sect2>Typedefs
<label id="sec:typedef">
<p>
%
%
An IDL typedef have the following form:
typedef type name;
The translation into a Haskell type declaration is
implemented as follows:
<verb>
D[typedef type name] = "DT[type] Con[name] = T[type]"
</verb>
where <tt/Con[]/ is the mapping from an IDL name to a
Haskell type constructor name and <tt/DT[]/ uses the IDL
type to determine what kind of Haskell user-defined data
type declaration to use.
The meat of the translation is done by the <tt/T[]/ mapping
scheme, which is implemented by <tt/toHaskellTy/ in @MarshallType@.
\begin{code}
cgTypedef :: Id -> Type -> CgM HDecl
cgTypedef tdef_id ty
| (idAttributes tdef_id) `hasAttributeWithName` CustomAttributes.ignoreAttr
= return emptyDecl
| otherwise = do
addExport (ieType hname (is_tysyn || optExportAbstractly))
d <- cgMarshallTy tdef_id ty
return (typedef `andDecl` d)
where
attrs = idAttributes tdef_id
hname = mkHaskellTyConName (idName tdef_id)
isNewType = attrs `hasAttributeWithName` CustomAttributes.newtypeAttr
isPure = attrs `hasAttributeWithName` CustomAttributes.pureAttr
-- the support for represent_as() is currently
-- restricted to types in typedefs (i.e., no
-- support for hooking in your own marshallers.)
(the_ty, tvs) =
case findAttribute "represent_as" attrs of
Just (Attribute _ (ParamLit (StringLit s):_)) -> (tyConst s, [])
_ ->
case (unconstrainType (groundTyVars (toHaskellTy True ty))) of
(ls,t) -> (purify t, map (qName.snd) ls)
purify ty1
| isPure = purifyType ty1
| otherwise = ty1
-- the DT[] translation. IDL simple types, arrays and pointers
-- are mapped onto type synonyms, the rest are algebraic data types.
is_tysyn =
isSimpleTy ty
|| isAbstractTy ty
|| isBoolTy ty
|| isArrayTy ty
|| isSafeArrayTy ty
|| isPointerTy ty
|| isSynTy ty
|| isFunTy ty
|| isIntegerTy ty
|| isStringTy ty
|| isSeqTy ty
typedef
| isNewType && null (tail conDecls) = dataType
| is_tysyn = tySyn hname tvs the_ty
| otherwise = dataType
conDecls = mkHaskellConDecls hname attrs ty
dataType =
TyD $
TyDecl (if isNewType then Newtype else Data)
hname
tvs
(if isNewType then (map recToConDecl conDecls) else conDecls)
derivings
derivings =
case findAttribute CustomAttributes.derivingAttr attrs of
Just (Attribute _ [ParamLit (StringLit s)]) -> map toQualName (split ',' s) ++ ds
_ -> ds
ds = addFlagDerivings $
case ty of
Enum _ kind vs | genDerivedEnumInstanceFor kind vs && not forceFlag -> [enumClass]
_ -> []
addFlagDerivings
| not optGenNumInstance && not optGenBitsInstance = id
| forceFlag = \ x -> (eqClass:showClass:x)
| otherwise =
case ty of
Enum _ EnumFlags{} _ -> \ x -> (eqClass:showClass:x)
_ -> id
forceFlag = optEnumsAsFlags ||
attrs `hasAttributeWithName` CustomAttributes.flagAttr
\end{code}
%
%
<sect2>Constants
<label id="sec:constants">
<p>
%
%
Generating the Haskell equivalent of a constant is pretty
straightforward, just introduce a constant declaration (+ type signature)
for it.
\begin{code}
cgConstant :: Id -> Type -> Type -> Expr -> CgM HDecl
cgConstant i t o_t e = do
addExport (ieValue hname)
return (typeSig hname ty `andDecl`
funDef hname [] expr)
where
ty = toHaskellTy True o_t
hname = mkHaskellVarName (idName i)
expr =
case t of
WString{} -> funApp mkWString [coreToHaskellExpr e]
String{} -> coreToHaskellExpr e
Integer{} -> coreToHaskellExpr e
Char{} -> coreToHaskellExpr e
Float{} -> coreToHaskellExpr e
WChar{} -> coreToHaskellExpr e -- this is currently mapped to Char, btw.
Bool -> coreToHaskellExpr e
Octet -> coreToHaskellExpr e
Pointer{} -> funApp intToAddr [ coreToHaskellExpr e ]
_ -> error ("cgConstant: don't know how to handle constant of type: " ++
showCore (ppType ty) ++ showParen True (shows (idName i)) "")
\end{code}
%
%
<sect2>Translating interfaces
<label id="sec:translate:interface">
<p>
%
%
\begin{code}
cgInterface :: Id -> InterfaceInherit -> [InterfaceDecl] -> CgM HDecl
cgInterface if_nm inherit decls = setIfaceName iface_name $ do
let
(iface_kind, is_bin)
| not (is_object || is_idispatch ) =
if (idAttributes if_nm) `hasAttributeWithName` "odl" then
(VTBLObject, True)
else
if notNull decls || optCorba || optJNI then
(VTBLObject, True)
else
(StdFFI, False)
| is_idispatch = (ComIDispatch isDual, False)
| otherwise = (VTBLObject, True)
the_decls_to_use
| is_idispatch =
case optIgnoreMethsUpto of
Nothing -> decls
Just x ->
case break (isEqualMethod x) decls of
(ds,[]) -> ds
(ds,_:xs) ->
-- keep any typedefs, but remove the methods
filter (not.isMethod) ds ++ xs
| otherwise = decls
isEqualMethod x d = isMethod d && idOrigName (declId d) == x
if is_bin && optDon'tGenBinaryComInterfaces then
trace ("Ignoring (binary) interface: "++ show iface_name) $
return emptyDecl
else do
setInterfaceFlag iface_kind $ do
setIEnumFlag is_ienum $ do
setMethodNumber startOffset
body <- setIfaceAttributes attrs (mapM coGen the_decls_to_use)
let typeInSepModule = optOneModulePerInterface && notNull deps
when typeInSepModule $ do
let ty_mod_nm = idName if_nm ++ "Ty"
addVitalExport (ieModule ty_mod_nm)
when (optNoExportList) (addVitalExport (ieModule (idName if_nm)))
addExplicitImports [(False, ty_mod_nm)]
ud <-
if is_javeh_interface then do
c <- cgJNIInterface if_nm typeInSepModule
return (infoHeader (Interface if_nm False inherit the_decls_to_use) `andDecl` c)
else if is_javeh_class then do
c <- cgJNIClass if_nm typeInSepModule
d <- setInterfaceFlag VTBLObject (uuidDecl if_nm inh Iid)
let
ds
| typeInSepModule = infoHeader (Interface if_nm False inherit the_decls_to_use) `andDecl` c
| otherwise = infoHeader (Interface if_nm False inherit the_decls_to_use) `andDecl` d `andDecl` c
return ds
else if typeInSepModule then do
return emptyDecl
else do
d <- uuidDecl if_nm inh Iid
return (infoHeader (Interface if_nm False inherit the_decls_to_use) `andDecl` d)
return (andDecls (ud:body))
where
is_javeh_interface = optJNI && not is_javeh_class
is_javeh_class = optJNI && attrs `hasAttributeWithName` CustomAttributes.jniClassAttr
attrs = idAttributes if_nm
iface_name = idName if_nm
deps = findDeps if_nm
coGen d
| isMethod d = do
d' <- cgDecl d
incMethodNumber
return d'
| otherwise = cgDecl d
startOffset
| iface_name == "IUnknown" = 0
| otherwise = sum (map snd inh)
isDual = attrs `hasAttributeWithName` "dual"
{-
Figuring out what kind of interface we've been presented with
is a little bit involved:
- if iface has [oleautomation] attr ==> it's an IDispatch thing.
- [dual] ==> IDispatch
- inherits from IDispatch derived iface ==> IDispatch
- [object] (but none of the above) ==> IUnknown (binary invoc., really.)
- [odl] (but none of the above) ==> same.
Whether the generated stubs for IDispatch interfaces are declared
as being dual should use Invoke() or binary invocation is controlled
by the -fdual-vtbl (optDualVtbl) flag.
-}
is_object =
attrs `hasAttributeWithName` "object" ||
any (\ x -> qName (fst x) == "IUnknown") inherit
-- extremely simplistic..
is_ienum =
not optNoEnumMagic &&
("IEnum" `isPrefixOf` iface_name &&
(length (filter isMethod decls)) == 4 &&
ok_looking_enum_names)
-- Dear, oh dear. ToDo: control this with a cmd-line switch instead.
ok_looking_enum_names =
case (map (idName.declId) (filter isMethod decls)) of
['r':'e':'m':'o':'t':'e':'N':'e':'x':'t':_
,'s':'k':'i':'p':_, 'r':'e':'s':'e':'t':_
,'c':'l':'o':'n':'e' : _
] -> True
['n':'e':'x':'t':_
,'s':'k':'i':'p':_, 'r':'e':'s':'e':'t':_
,'c':'l':'o':'n':'e' : _
] -> True
_ -> False
is_idispatch =
-- Not right, [oleautomation] only constrains the set of valid types.
--is_oleaut ||
(isDual && not optDualVtbl) ||
(any (\ x -> qName (fst x) == "IDispatch" &&
iface_name /= "IDispatchEx") inherit &&
not (isDual && optDualVtbl))
inh =
case inherit of
[] | optCorba -> [(cObject, 0)]
| optHaskellToC || idName if_nm == "IUnknown" -> []
| otherwise -> [(iUnknown, 3)]
xs@((x,_):_)
-- if we've decided that we're processing an
-- Automation interface, but we've got an IUnknown
-- in our hand as the interface we're inheriting from.
-- Ignore, and pretend it's an IDispatch instead.
| is_idispatch && (not is_object) && qName x == "IUnknown" ->
trace ("Odd, interface " ++ show (idName if_nm) ++
"inherits from IUnknown, but has been classified as an Automation interface\n" ++
"(it will be treated as an Automation interface.)")
[(iDispatch, 7)]
-- special case for IUnknown:
| is_object && idName if_nm == "IUnknown" -> []
| otherwise -> map toStdNames xs
where
-- Just to make sure that we're using them
-- in a proper qualified manner...
toStdNames (n,meths) =
case (qName n) of
{- Ensuring that re-defns of these two are short-circuited to the
library-provided impls, is now done by the desugarer.
ToDo: delete this once we're certain that this catches all of 'em.
"IDispatch" -> (iDispatch,7)
"IUnknown" -> (iUnknown,3)
-}
nm -> (n{qName=mkIfaceTypeName nm}, meths)
\end{code}
\begin{code}
data GuidKind
= Iid | Clsid | Libid
deriving ( Eq )
uuidDecl :: Id -> InterfaceInherit -> GuidKind -> CgM HDecl
uuidDecl i inherit guidKind = do
flg <- getInterfaceFlag
forClient <- getClientFlag
case flg of
StdFFI | forClient -> do
addExport (ieType tycon_nm optExportAbstractly)
decls <- marshallAbstract i
return (abs_ty `andDecl` decls)
_ -> do
case (getUuidAttribute attrs) of
Nothing
| guidKind == Iid -> do
addExport (ieType iface_ptr_ty_nm False)
addExport (ieType i_tycon_nm_dummy False)
ds <-
if null inherit && optHaskellToC then do
ds <- marshallAbstract i
return ( abs_ty `andDecl` ds)
else
return emptyDecl
return ( ds `andDecl`
iface_dummy_ty `andDecl`
iface_ptr_ty
)
| otherwise -> return emptyDecl
Just guid -> do
when (guidKind == Iid) (addExport (ieType iface_ptr_ty_nm True))
when (guidKind == Iid && not_iunknown) (addExport (ieType i_tycon_nm_dummy True))
when (not no_libids) (addExport (ieValue iid_name))
return (iface_dummy_ty `andDecl`
iface_ptr_ty `andDecl`
iid_def)
where
no_libids = guidKind == Libid && (optNoLibIds || optUseStdDispatch)
iid_name = iid_prefix ++ iface_ptr_ty_nm
iid_def
| no_libids = emptyDecl
| otherwise = iid_tysig `andDecl` iid_decl
iid_tysig = typeSig iid_name (iid_tycon iid_tycon_args)
iid_decl = funDef iid_name [] iid_rhs
iid_tyarg =
tyCon
iface_ptr_ty_nm
(if not optSubtypedInterfacePointers then
[]
else
[mkTyConst groundInterface])
iid_rhs = funApp mk_iid [lit (StringLit ('{':(concat (intersperse "-" guid)) ++ "}"))]
iid_tycon_args =case guidKind of { Iid -> [iid_tyarg] ; _ -> [] }
mk_iid =
case guidKind of
Iid -> mkIID
Clsid -> mkCLSID
Libid -> mkLIBID
(iid_prefix, iid_tycon) =
case guidKind of
Iid -> ("iid", mkTyCon iID)
Clsid -> ("clsid", \ _ -> mkTyConst cLSID)
Libid -> ("libid", \ _ -> mkTyConst lIBID)
where
not_iunknown = idName i /= "IUnknown"
{-
For interface 'ITest', we generate:
data Test a = Test__
type ITest a = IUnknown (Test a)
where 'IUnknown' is the interface ITest inherits from.
-}
iface_dummy_ty
| (guidKind /= Iid) = emptyDecl
| isAuto && optUnparamedInterfacePointers = tySyn i_tycon_nm [] (mkTyConst iDispatch)
| optSubtypedInterfacePointers =
case idName i of
"IUnknown" -> emptyDecl -- it's in a library.
_ -> dataTy (i_tycon_nm_dummy) ["a"] [conDecl (i_tycon_nm++"__") []]
| otherwise = emptyDecl
iface_ptr_ty
| (guidKind /= Iid) = emptyDecl -- coclass decl doesn't get a type syn.
| optSubtypedInterfacePointers =
case idName i of
"IUnknown" ->
tySyn iface_ptr_ty_nm ["a"] (mkTyCon iUnknown [tyVar "a"])
_ | notNull inherit ->
tySyn iface_ptr_ty_nm ["a"]
(mkTyCon inh_from [tyCon (i_tycon_nm_dummy) [tyVar "a"]])
| otherwise ->
emptyDecl
| null inherit = emptyDecl
| otherwise = tySyn iface_ptr_ty_nm [] (mkTyConst inh_from)
i_tycon_nm_dummy = i_tycon_nm ++ "_"
isAuto =
case flg of
ComIDispatch _ -> True
_ -> False
iface_ptr_ty_nm
| guidKind == Iid = mkIfaceTypeName (idName i)
| otherwise = mkHaskellTyConName (idName i)
inh_from =
let q_nm = fst (head inherit) in
case qName q_nm of
"IUnknown" | isDual -> iDispatch
-- I'm not kidding - this kind of bogosity
-- does appear in Real Life.
_ -> q_nm
where
-- drop common prefixes from the (disp)interface/coclass name..
i_tycon_nm = mkHaskellTyConName (mkIfaceTypeName (idName i))
attrs = idAttributes i
tycon_nm = mkHaskellTyConName (idName i)
abs_ty_args =
case findAttribute CustomAttributes.tyArgsAttr attrs of
Just (Attribute _ [ParamLit (StringLit s)]) -> words s
_ -> []
abs_ty = newTy tycon_nm abs_ty_args (conDecl tycon_nm [the_abs_ty]) derivings
abs_ty_h = tyCon tycon_nm (map tyConst abs_ty_args)
isDual = attrs `hasAttributeWithName` "dual"
derivings =
case findAttribute CustomAttributes.derivingAttr attrs of
Just (Attribute _ [ParamLit (StringLit s)]) -> map toQualName (split ',' s)
_ -> []
the_abs_ty
| attrs `hasAttributeWithName` CustomAttributes.finaliserAttr
= tyForeignPtr abs_ty_h
| otherwise = tyPtr abs_ty_h
findDeps :: Id -> [String]
findDeps i = map remove $ filterAttributes attrs ["depender"]
where
remove (Attribute _ [ParamLit (LitLit s)]) = s
remove _ = ""
attrs = idAttributes i
\end{code}
%
%
<sect2>Translating dispinterfaces
<label id="sec:translate:dispinterface">
<p>
%
%
Very much like the translation of a `normal' interface:
\begin{code}
cgDispInterface :: Id -> Maybe Decl -> [Decl] -> [Decl] -> CgM HDecl
cgDispInterface i ii props meths =
withIfaceInherit [iUnknown,iDispatch] $
setIfaceName (idName i) $
inDispInterface $
setInterfaceFlag (ComIDispatch False) $ do
is_src <- getSourceIfaceFlag
let is_source = is_src || hasSourceAttribute (idAttributes i)
setSourceIfaceFlag is_source $ do
forClient <- getClientFlag
body <- mapM cgDecl (props ++ meths)
ud <- uuidDecl i [(iDispatch,7)] Iid
if is_source && optIgnoreSourceIfaces then
return (infoHeader (DispInterface i ii props meths) `andDecl` ud)
else do
{-
It may look a bit funny to generate a VTBL for a
dispinterface server too, but that's how we implement
'em. The type library based IDispatch marshaller needs to
be passed a method table.
-}
vtbl <-
if (forClient && not is_source) || (not forClient && is_source) then
return emptyDecl
else
let
is_wrapper = isJust ii
stuff =
case ii of
Just (Interface{declDecls=ds}) -> ds
_ -> props ++ meths
in
mkServVTBL i (is_source || optUseStdDispatch) is_wrapper stuff
return (infoHeader (DispInterface i ii props meths) `andDecl`
ud `andDecl`
vtbl `andDecl`
andDecls body
)
\end{code}
%
%
<sect2>Translating coclasses
<label id="sec:translate:dispinterface">
<p>
%
%
If we're splitting up the IDL input up into one Haskell module per (disp)interface,
a coclass declaration gives rise to a Haskell module that re-exports the interfaces
it implements plus it defines its CLSID.
\begin{code}
cgCoClass :: Id -> [CoClassDecl] -> CgM HDecl
cgCoClass i cdecls
| optOneModulePerInterface = do
don't_gen_code_for_cls <-
case cdecls of
[x] | isJust (coClassDecl x) ->
hoistInClass (idName (coClassId x)) $ \ mb_cls ->
return (isJust mb_cls)
_ -> return False
if don't_gen_code_for_cls then
return emptyDecl
else do
addExplicitImports import_modules
sequence (map (addExport.ieModule.snd) import_modules)
ud <- setInterfaceFlag (ComIDispatch False) (uuidDecl i [] Clsid)
return (prettyPrint ud)
| otherwise = do
forClient <- getClientFlag
ud <- setInterfaceFlag (ComIDispatch False) (uuidDecl i [] Clsid)
body <-
if (not forClient) then
getDeclName $ \ lib_nm ->
mkServMain lib_nm i cdecls
else
return emptyDecl
return ( prettyPrint ud `andDecl` body)
where
import_modules = map (\ x -> (True, idName (coClassId x))) the_cdecls
-- weed out the dispinterfaces, if we've been told to do so.
isIface CoClassInterface{} = True
isIface _ = False
the_cdecls
| optIgnoreDispInterfaces = filter (isIface) cdecls
| otherwise = cdecls
prettyPrint d = infoHeader (CoClass i cdecls) `andDecl` d
\end{code}
\begin{code}
cgLibrary :: Id -> [Decl] -> CgM HDecl
cgLibrary i lib_decls =
withDeclName (idName i) $ do
ud <- setInterfaceFlag (ComIDispatch False) (uuidDecl i [] Libid)
ds <- mapM cgDecl lib_decls
return ( prettyPrint ud `andDecl` andDecls ds)
where
prettyPrint d
| optNoLibIds = emptyDecl
| otherwise = infoHeader (Library i lib_decls) `andDecl` d
\end{code}
%
%
<sect2>Translating modules
<label id="sec:translate:module">
<p>
%
%
Translating a module isn't too much work, set the flag
to indicate that we're processing 'static' decls inside
the module and tell everyone what DLL it's coming from
(if any.)
\begin{code}
cgModule :: Id -> [Decl] -> CgM HDecl
cgModule i ds =
setInterfaceFlag StdFFI $
withDeclName (idName i) $
mbSetDllName $ do
hs <- mapM cgDecl ds
return (infoHeader (Module i ds) `andDecl` andDecls hs)
where
mbSetDllName x =
case (findAttribute CustomAttributes.dllNameAttr (idAttributes i)) of
(Just (Attribute _ [ParamLit (StringLit s)])) -> setDllName s x
_ -> x
\end{code}
%
%
<sect2>Translating types
<label id="sec:translate:type">
<p>
%
%
Converting an IDL type into its Haskell equivalent. The translation
is in some cases guided by attributes, e.g., the presence of the
`string' attribute turns char* into a `String'.
\begin{code}
mkHaskellConDecls :: Name -> [Attribute] -> Type -> [ConDecl]
mkHaskellConDecls nm attrs ty =
map (groundTys) $
case ty of
Enum _ k vals -> mkHEnumDef nm attrs k vals
Union _ _ _ _ switches -> mkHUnionDef nm switches
UnionNon _ switches -> mkHUnionDef nm switches
CUnion _ fields _ -> mkCUnionDef fields
Struct tag mem _ -> [mkHStructDef tag mem]
-- [abstract] is undoc'ed and will probably disappear soon,
-- don't use..
Pointer _ _ Iface{}
| attrs `hasAttributeWithName` CustomAttributes.abstractAttr
-> [ConDecl nm [Unbanged abs_ty]]
where
abs_ty
| attrs `hasAttributeWithName` CustomAttributes.finaliserAttr
= tyForeignObj
| otherwise = tyAddr
Pointer pt _ t ->
case pt of
Ptr -> [ConDecl "Ptr" [Unbanged (toHaskellTy True t)]]
Ref -> mkHaskellConDecls nm attrs t
Unique -> [ConDecl "Maybe" [Unbanged (toHaskellTy True t)]]
_ -> let
str = showAbstractH (ppType (toHaskellTy True ty))
in
trace ("mkHaskellConDecls: odd argument: " ++ str)
[ConDecl str []]
where
-- remove any left-over
groundTys (ConDecl n bs) = ConDecl n (map groundBangTy bs)
groundTys (RecDecl n rs) = RecDecl n (map (\ (i,t) -> (i,groundBangTy t)) rs)
groundBangTy (Banged t) = Banged (groundTyVars t)
groundBangTy (Unbanged t) = Unbanged (groundTyVars t)
\end{code}
Top level function for creating code for (constructed)
IDL types:
* we don't generate any marshalling code for the different
IDL pointer types. Instead, we provide parameterised marshallers
in a library and just parameterise them approp. when we need
to swizzle pointers to/from the outside world. i.e., we're
interested in keeping the size of the generated code down.
\begin{code}
cgMarshallTy :: Id -> Type -> CgM HDecl
cgMarshallTy i ty =
case ty of
Struct tag members mb_pack ->
case (mkHaskellConDecls (idName tag) (idAttributes tag) ty) of
[cdecl] -> marshallStruct (idName i) tag cdecl members mb_pack
_ -> error "cgMarshallTy{Struct}: expected one condecl"
Enum _ k fields -> marshallEnum i k (genDerivedEnumInstanceFor k fields) fields
Union _ tag_ty tag _ sws ->
marshallUnion (idName i) (Left (tag,tag_ty)) False sws Nothing
UnionNon tag sws ->
let
as = idAttributes i ++ idAttributes tag
tag_ty = getTagTy as
in
marshallUnion (idName i) (Right tag_ty) False sws Nothing
CUnion tag fields mb_pack ->
let
as = idAttributes i ++ idAttributes tag
tag_ty = getTagTy as
switches = map fieldToSwitch fields
fieldToSwitch (Field fi t ot _ _) = Switch fi labs t ot
where
labs =
case findAttribute "case" (idAttributes i) of
Just (Attribute _ ls) -> mapMaybe toCase ls
_ -> []
toCase (ParamExpr e) = Just (Case e)
toCase (ParamVar v) = Just (Case (Var v))
toCase _ = Nothing
in
marshallUnion (idName i) (Right tag_ty) True{-is C union-} switches mb_pack
FunTy _ _ _ -> marshallFun Nothing i ty
_ -> return emptyDecl
where
getTagTy as =
case findAttribute "switch_type" as of
Just (Attribute _ [ParamType t]) -> t
_ ->
case getSwitchIsAttribute as of
Just (Cast t _) -> t
_ -> Integer Long True
\end{code}
\begin{code}
marshallServ :: Id
-> InterfaceInherit
-> [InterfaceDecl]
-> CgM HDecl
marshallServ ifaceId inherit decls = do
let
iface_kind
| not (isObject || isIDispatch ) =
if attrs `hasAttributeWithName` "odl" || optCorba || optJNI then
VTBLObject
else
StdFFI
| isIDispatch = ComIDispatch isDual
| otherwise = VTBLObject
setInterfaceFlag iface_kind $ do
setIfaceName iface_name $ do
is_src <- getSourceIfaceFlag
setMethodNumber startOffset
body <- mapM coGen decls
ud <-
if is_javeh_interface then
return emptyDecl
else
uuidDecl ifaceId inherit Iid
vtbl <-
if optJNI then
cgJClass ifaceId decls
else
mkServVTBL ifaceId (is_src && isIDispatch) False decls
return (infoHeader (Interface ifaceId False inherit decls) `andDecl`
ud `andDecl`
vtbl `andDecl`
andDecls body)
where
iface_name = idName ifaceId
attrs = idAttributes ifaceId
is_javeh_interface = optJNI && not is_javeh_class
is_javeh_class = optJNI && attrs `hasAttributeWithName` CustomAttributes.jniClassAttr
coGen d
| isMethod d = do
d' <- cgDecl d
incMethodNumber
return d'
| otherwise = cgDecl d
startOffset
| iface_name == "IUnknown" = 0
| otherwise = sum (map snd inherit)
isIDispatch =
(isDual && not optDualVtbl) ||
(any (\ x -> qName (fst x) == "IDispatch" &&
iface_name /= "IDispatchEx") inherit && not (isDual && optDualVtbl))
isDual = attrs `hasAttributeWithName` "dual"
isObject = attrs `hasAttributeWithName` "object" ||
any (\ x -> qName (fst x) == "IUnknown") inherit
\end{code}