%
% (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 )
-> Env String [ ( Result , [ Param ] ) ]
-> Env String ( Maybe Id )
-> [ Decl ]
-> ( [ ( String , Decl ) ]
, [ ( String , Bool , [ HTopDecl ] ) ]
)
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
modules =
case mods_and_libs of
[ _ ] -> [ one_module ]
_ ->
case rest of
[] -> mods_and_libs
_ -> top_module : mods_and_libs
toStdOut =
case o_fname of
Right "-" -> True
_ -> False
( 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
[ ] )
rest
)
one_module = ( output_fname
, top_module_name
, mkTopModule ( mkId top_module_name
top_module_name
Nothing
[ ] )
flattened_decls
)
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
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 <-
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}
%
%
Typedefs
%
%
An IDL typedef have the following form:
typedef type name;
The translation into a Haskell type declaration is
implemented as follows:
D[typedef type name] = "DT[type] Con[name] = T[type]"
where 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_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
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}
%
%
Constants
%
%
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
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}
%
%
Translating interfaces
%
%
\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 ) ->
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"
is_object =
attrs `hasAttributeWithName` "object" ||
any ( \ x -> qName ( fst x ) == "IUnknown" ) inherit
is_ienum =
not optNoEnumMagic &&
( "IEnum" `isPrefixOf` iface_name &&
( length ( filter isMethod decls ) ) == 4 &&
ok_looking_enum_names )
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 =
( 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 , _ ) : _ )
| 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 ) ]
| is_object && idName if_nm == "IUnknown" -> []
| otherwise -> map toStdNames xs
where
toStdNames ( n , meths ) =
case ( qName n ) of
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"
iface_dummy_ty
| ( guidKind /= Iid ) = emptyDecl
| isAuto && optUnparamedInterfacePointers = tySyn i_tycon_nm [] ( mkTyConst iDispatch )
| optSubtypedInterfacePointers =
case idName i of
"IUnknown" -> emptyDecl
_ -> dataTy ( i_tycon_nm_dummy ) [ "a" ] [ conDecl ( i_tycon_nm ++ "__" ) [] ]
| otherwise = emptyDecl
iface_ptr_ty
| ( guidKind /= Iid ) = emptyDecl
| 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
_ -> q_nm
where
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}
%
%
Translating dispinterfaces
%
%
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
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}
%
%
Translating coclasses
%
%
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
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}
%
%
Translating modules
%
%
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}
%
%
Translating types
%
%
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 ]
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
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 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}