% % (c) University of Glasgow, 1998-1999 % Sigbjorn Finne, 2000- % % @(#) $Docid: Nov. 24th 2003 07:50 Sigbjorn Finne $ % @(#) $Contactid: sof@galois.com $ % \begin{code} module Desugar ( desugar ) where import qualified IDLSyn as IDL import qualified PpIDLSyn as PpIDL ( ppType ) import IDLUtils hiding ( childAttributes, getTyTag ) import qualified IDLUtils ( childAttributes, getTyTag ) import qualified CoreIDL as Core import CoreUtils ( getTyTag, simpRedExpr, mkHaskellTyConName , mkId, removePtr, findPtrType, isMethod , iUnknownTy, iDispatchTy, childAttributes , int16Ty, currencyTy , dateTy, dummyMethod, intTy, variantTy, bstrTy , mkRefPointer, rawPointerToIP, isIfacePtr, getIfaceTy ) import Attribute ( stringToDepReason, hasStringAttribute, hasSeqAttribute, getLengthAttribute, hasModeAttribute, findAttribute, hasAttributeWithName, hasUniqueAttribute, hasDependentAttrs, hasSourceAttribute, getDefaultCConv ) import DsMonad import Env import BasicTypes import Literal import Opts ( optOneModulePerInterface, optVerbose, optExpandInheritedInterface, optIgnoreDispInterfaces, optCompilingMsIDL, optOutPointersAreRefs, optSubtypedInterfacePointers, optTlb, dumpIDL, optIgnoreImpLibs, optUnwrapSingletonStructs, optNukeEmptyStructs, optJNI, optCompilingOmgIDL, optCorba, optHaskellToC, optVoidTydefIsAbstract, optNoWarnMissingMode, optUseAsfs, optDon'tTidyDefns, optTlb, optServer, optUseStdDispatch ) import Utils import NormaliseType import ImportLib ( importLib ) import PpIDLSyn ( showIDL, ppDefn ) import PpCore ( ppType, showCore ) import LibUtils ( defaultCConv, prelude, autoLib, comLib, iUnknown, iDispatch, jObject, cObject, jniLib, intLib, wordLib, hdirectLib, wStringLib ) import NameSupply import Int import Monad import Maybe ( isJust, fromJust, fromMaybe ) import Char ( toLower, isSpace ) import List ( partition, sort, sortBy, isPrefixOf ) import TypeInfo import Validate \end{code} The store front is @desugar@, which converts a set of definitions into the form expected by the code generator. By this stage, we assume that the definitions have been checked for `well-formedness' (legal types, definitions/types in scope etc.), so that we can just go about doing the transformation from IDLSyn to Core. \begin{code} desugar :: String -> Env String (Bool, [IDL.Attribute]) -> [IDL.Defn] -> IO ([Core.Decl], TypeEnv, TagEnv, SourceEnv, IfaceEnv) desugar srcFileName aenv defs = runDsM srcFileName tenv_to_use aenv def_types (desugarer srcFileName defs) where def_types | optCompilingMsIDL = ms_idl_def_types | otherwise = [] tenv_to_use | optCompilingMsIDL = addListToEnv newEnv [ ("VARIANT", variant_ti) , ("IID", iid_ti) , ("CLSID", clsid_ti) , ("GUID", guid_ti) , ("VARIANT_BOOL", v_bool_ti) , ("BSTR", bstr_ti) ] | otherwise = newEnv ms_idl_def_types = [ ("IUnknown", comLib, Core.Iface "IUnknown" comLib "IUnknown" [] False []) , ("IDispatch", autoLib, Core.Iface "IDispatch" autoLib "IDispatch" [] True [(iUnknown,3)]) , ("CURRENCY", autoLib, currencyTy) , ("DATE", autoLib, dateTy) , ("BSTR", comLib, bstrTy) , ("VARIANT_BOOL", autoLib, Core.Name "VARIANT_BOOL" "VARIANT_BOOL" autoLib Nothing (Just int16Ty) (Just v_bool_ti)) , ("IID", comLib, Core.Name "IID" "IID" comLib Nothing Nothing (Just iid_ti)) , ("CLSID", comLib, Core.Name "CLSID" "CLSID" comLib Nothing Nothing (Just clsid_ti)) , ("GUID", comLib, Core.Name "GUID" "GUID" comLib Nothing Nothing (Just guid_ti)) , ("VARIANT", autoLib, variantTy) , ("int64", intLib, Core.Integer LongLong True) , ("uint64", wordLib, Core.Integer LongLong False) , ("HRESULT", comLib, Core.Integer Long True) , ("LPSTR", comLib, Core.String (Core.Char False) False Nothing) , ("LPWSTR", wStringLib, Core.WString False Nothing) , ("bool", prelude, Core.Bool) , ("wchar_t", hdirectLib, Core.WChar) , ("octet", hdirectLib, Core.Octet) ] {- desugarer is the entry point for the translation of a spec, be it imported or at the root. ToDo: the unique names needs to be moved into DsM - this is going to break in mysterious ways.. -} desugarer :: String -> [IDL.Defn] -> DsM [Core.Decl] desugarer src defs = do let defs' = tidyDefns (concat (runNS (mapM fillInDefn defs) names)) (res, _) <- desugarIncludedDecls src Nothing [] defs' return (reverse res) where names = [ prefix ++ show i | i <- [(0::Int)..]] prefix = "__IHC_TAG_" {- it is rather unfortunate that since we're folding over the sequence of declarations, desugarDefn cannot make 'global' decisions - introducing a new scope by the presence of IncludeStart (and IncludeEnd.), for example. Instead we're forced to lift this out to here, using explicit recursion & testing to handle this. ToDo: Re-think this structure sometime in the future. -} desugarIncludedDecls _ _ acc [] = return (acc, []) desugarIncludedDecls src keepIt acc (x:xs) = case x of IDL.IncludeStart headerFileName -- delay this from kicking in until we see the first occurrence of -- a '#line' for the source file (avoids running into trouble with -- other line gunk the CPP may emit.) | isJust keepIt || headerFileName == src -> do old_nm <- getFilename let mod' = mkHaskellTyConName (dropSuffix (basename headerFileName)) mod <- nameOfImport mod' setFilename (Just mod) let -- we're only interested in generating code for the portions -- that belong to the source .idl. -- ToDo: conditionalise this and optionally be interested in -- contents of #include files. forKeeps = fromMaybe True keepIt && headerFileName == src (new_acc, xs') <- desugarIncludedDecls src (Just forKeeps) acc xs setFilename old_nm desugarIncludedDecls src keepIt new_acc xs' IDL.IncludeEnd -> return (acc, xs) _ -> do new_acc <- desugarDefn acc x let keep = fromMaybe True keepIt the_acc | keep = new_acc | otherwise = acc desugarIncludedDecls src keepIt the_acc xs \end{code} %* % \section[desugarDefn]{Converting a definition into CoreIDL} % %* \begin{code} desugarDefn :: [Core.Decl] -> IDL.Defn -> DsM [Core.Decl] {- When parsing typedefs like typedef [foo]bar* baz; The attribute part is parsed as part of the type, and the pointer is parsed as being part of the declarator `baz'. When desugaring into Core form, attributes are pinned onto Core Ids, and the pointer (or array) nature of an Id is recorded in its associated Core type. Types aren't currently pinned directly onto Ids, instead the context in which they appear records their type. Notice that we currently enter the new type name plus its definition into a type environment *and* return a Core.Typedef decl. The type declaration is stored in an environment so that we later can reduce a type down to its primitive form (i.e., expand out synonyms.) Reducing types avoid having to create marshalling code for the typedefs themselves. -} desugarDefn acc (IDL.Typedef ty tdef_attrs ids) | optNukeEmptyStructs && isEmptyStructTy ty = return acc | optVoidTydefIsAbstract && isVoidTyDef ty ids = desugarDefn acc (IDL.Interface (head ids) [] []) | otherwise = do core_tdef_attrs <- addToPath (iName (head ids)) $ idlToCoreAttributes tdef_attrs if hasAttributeWithName core_tdef_attrs "abstract" then -- -- decls of the forms: typedef [abstract,...] struct foo Foo; -- are equal to interface Foo{}; -- withAttributes core_tdef_attrs $ desugarDefn acc (IDL.Interface (head ids) [] []) else do mod <- getFilename inherited_attrs <- getAttributes let child_attrs = childAttributes inherited_attrs {- A typedef such as: typedef struct _tag { ... } *foo; is problematic, since it doesn't have a particularly descriptive Haskell type: type Foo = Pointer Addr {- or maybe just Addr -} To solve this, we introduce a dummy typedef: typedef struct _tag { ... } structTag, *foo; and as a result will generate data StructTag = Tag ... type Foo = Pointer StructTag [10/10/98: drop the typePrefix on the generated type's name, i.e., it's now data Tag = Tag ... , rather than data StructTag = Tag ... -- sof] (this will only happen for typedefs on structs, unions and enums.) -} fixed_ids = case filter isUnpointedId ids of [] -> let t = tyTag ty in(IDL.Id t:ids) (x:_) -> {- In the case where you've got *foo,*bar,baz - ensure that the unpointed id is processed first, so that we don't get any forward type references. -} x: filter (\ i -> iName i /= iName x) ids -- unpointed synonym that all pointer and array syns can `point' to. ground_syn = case map removeIdAttrs (filter isUnpointedId fixed_ids) of (IDL.Id x:_) -> x mkCoreTypeDef accum i | isUnpointedId i && (iName i == ground_syn) = addToPath (iName i) $ do -- notice that we augment the path (for the benefit of ASFs) before -- the attributes are converted, which is why the conversion cannot be -- lifted out of this action. core_tdef_attrs1 <- idlToCoreAttributes (tdef_attrs ++ idAttrs i) let core_tdef_attrs' = childAttributes core_tdef_attrs1 final_attrs = core_tdef_attrs1 ++ inherited_attrs asNewType = final_attrs `hasAttributeWithName` "hs_newtype" when (not (isEmptyStructTy ty)) (addToTagEnv (IDLUtils.getTyTag (iName i) ty) (iName i)) -- add tag name to environment, so that recursive types can -- be handled correctly. -- -- Not a principled approach to recursive types, this. (nm, core_ty, real_ty) <- withAttributes child_attrs (mkCoreIdTy ty i True core_tdef_attrs') the_mod <- getFilename let core_id = mkCoreTypeId nm the_mod final_attrs core_ty' | asNewType && not (isConstructedTy ty) = Core.Struct core_id [Core.Field core_id core_ty real_ty Nothing Nothing] Nothing | otherwise = core_ty addToTypeEnv nm mod (core_ty', final_attrs) return (Core.Typedef core_id core_ty' core_ty' : accum) | otherwise= addToPath (iName i) $ do -- don't redeclare, just make the synonym point to -- the ground one. core_tdef_attrs1 <- idlToCoreAttributes (tdef_attrs ++ idAttrs i) let core_tdef_attrs' = childAttributes core_tdef_attrs1 (nm, core_ty, real_ty) <- withAttributes child_attrs (mkCoreIdTy (IDL.TyName ground_syn Nothing) i True core_tdef_attrs') addToTypeEnv nm mod (core_ty, core_tdef_attrs1 ++ child_attrs) return (Core.Typedef (mkCoreTypeId nm mod core_tdef_attrs1) core_ty core_ty : accum) mkCoreSimpleTypeDef accum i = addToPath (iName i) $ do core_local_attrs <- idlToCoreAttributes (tdef_attrs ++ idAttrs i) let local_inh_attrs = childAttributes core_local_attrs the_tdef_attrs = core_local_attrs ++ inherited_attrs asNewType = the_tdef_attrs `hasAttributeWithName` "hs_newtype" (nm, core_ty, real_ty) <- withAttributes inherited_attrs (mkCoreIdTy ty i True local_inh_attrs) let core_id = mkCoreTypeId nm mod the_tdef_attrs core_ty' | asNewType = Core.Struct core_id [Core.Field core_id core_ty real_ty Nothing Nothing] Nothing | otherwise = core_ty addToTypeEnv nm mod (core_ty', the_tdef_attrs) return (Core.Typedef core_id core_ty' core_ty' : accum) mkCoreTypeId nm modu attr = mkId nm nm modu attr if not (isConstructedTy ty) then foldM mkCoreSimpleTypeDef acc ids else foldM mkCoreTypeDef acc fixed_ids -- an enum,struct or union are the only legal type declarations. -- - add to type environment and return. desugarDefn acc (IDL.TypeDecl ty) = do attrs <- getAttributes core_ty <- propagateAttributes attrs (idlToCoreTy ty) let nm = Core.idName (getTyTag core_ty) mod <- getFilename addToTypeEnv nm mod (core_ty, attrs) return (Core.Typedef (mkId nm nm mod attrs) core_ty core_ty : acc) desugarDefn acc (IDL.ExternDecl ty [i]) | optHaskellToC = desugarDefn acc (IDL.Operation (mkMethodId i) ty Nothing Nothing) | otherwise = return acc desugarDefn acc IDL.ExternDecl{} = return acc desugarDefn acc (IDL.Constant i as ty e) = addToPath (iName i) $ do core_as <- idlToCoreAttributes (as ++ idAttrs i) attrs <- getAttributes let child_attrs = core_as ++ childAttributes attrs (nm, core_ty, real_ty) <- withAttributes child_attrs (mkCoreIdTy ty i True []) core_expr <- idlToCoreExpr e cenv <- getConstEnv let core_expr' = simpRedExpr cenv core_ty core_expr core_int = case core_expr' of Core.Lit (IntegerLit x) -> Left (iLitToIntegral x) _ -> Right core_expr' addToConstEnv (iName i) core_int mod <- getFilename return (Core.Constant (mkId nm (iName i) mod child_attrs) real_ty core_ty core_expr' : acc) desugarDefn acc IDL.Attribute{} = do addWarning ("desugarDefn: attribute not implemented!") return acc desugarDefn acc (IDL.Attributed attrs d) {- | isLeafDefn d = do -- if method or typedef, aggregate attributes.. as <- getAttributes core_attrs <- idlToCoreAttributes attrs withAttributes (core_attrs ++ as) (desugarDefn acc d) | otherwise -} = do -- ..if interface/module/library/dispinterface/coclass, don't. as <- getAttributes core_attrs <- idlToCoreAttributes attrs withAttributes (core_attrs ++ as) (desugarDefn acc d) desugarDefn acc (IDL.Operation i ty _ _) = addToPath (iName i) $ do -- attrs will contain the attributes pinned onto method result type (if any.) inh_attrs <- getAttributes attrs <- augmentAttributes inh_attrs in_import <- isInImportedContext mb_iface <- getInterface let isWithinIface = isJust mb_iface {- when processing a COM method call, we drop methods which have call_as() attributes (the remotable cousin of some other [local] interface method.) It's a bit unfortunate that we cannot make use of this remotable version, since it is often specified more precisely (e.g., [size_is()] and friends are used), which is helpful when trying to generating Haskell friendly signatures. However, since the parameters that the remotable version of a method takes doesn't have to have any correlation to the parameters of the [local] method, we're stuck and have to drop the [call_as()] version. Such is life. sof 11/98 -} if ( isWithinIface && attrs `hasAttributeWithName` "call_as" ) then return acc else if in_import then {- If the method occurs in an imported context, don't bother desugaring it, since we're not going to generate code for it anyway. Insert a dummy method so that the computation of vtbl offsets don't go bad as a result. -} return (dummyMethod:acc) else do let (fun_id, mb_cc, fun_params) = case i of IDL.FunId f cc ps -> (f, cc, ps) x -> (x, Nothing, []) (nm, core_ty, real_ty) <- mkCoreIdTy ty fun_id True attrs propagateAttributes attrs $ do core_args <- idlToCoreParams (iName i) fun_params mod <- getFilename let callconv = fromMaybe defaultCConv (mb_cc `mplus` getDefaultCConv attrs) (meth_nm, orig_nm) = case findAttribute "call_as" attrs of Just (Core.Attribute _ [Core.ParamVar v]) | isWithinIface -> (v, v) Just (Core.Attribute _ [Core.ParamLit (TypeConst v)]) | isWithinIface -> (v, v) Just (Core.Attribute _ [Core.ParamLit (StringLit v)]) | isWithinIface -> (v, v) _ -> (nm, iName i) meth = Core.Method (mkId meth_nm orig_nm mod attrs) callconv (Core.Result real_ty core_ty) core_args Nothing return (meth:acc) desugarDefn acc (IDL.Interface (IDL.Id nm) inherits defs) = addToPath nm $ do inh_attrs <- getAttributes attrs <- augmentAttributes inh_attrs mod <- getFilename when optOneModulePerInterface (setFilename (Just nm)) withInterface nm $ do let iface_nm | optJNI = mkHaskellTyConName (snd (splitLast "." nm)) | otherwise = nm isClass = attrs `hasAttributeWithName` "jni_class" {- As an experimental hack, we support the [ty_params("args")] attribute which is appended to the Haskell type name of iface_args = case findAttribute "ty_params" attrs of Just (Core.Attribute _ [Core.ParamLit (StringLit s)]) -> s _ -> [] -} home_mod | optOneModulePerInterface = Just iface_nm | otherwise = mod (inherited_decls, inherited_ifaces) <- do stuff <- mapM expandIface inherits let (iss, core_inheritss) = unzip stuff core_inherits = concat core_inheritss the_core_inherits | optJNI && null core_inherits && isClass = [(jObject,0)] | optCorba && null core_inherits = [(cObject,0)] | otherwise = core_inherits is | (not optExpandInheritedInterface) || null inherits = [] | otherwise = concat iss return (is, the_core_inherits) let is_idispatch = any (\ x -> "IDispatch" == qName (fst x)) inherited_ifaces && iface_nm /= "IDispatchEx" -- Insert a typedef that says that the interface name is an interface, so -- that interface pointers can be marshalled properly at a later stage. -- (including the methods of this very interface). addToTypeEnv nm home_mod (Core.Iface iface_nm home_mod nm attrs is_idispatch (reverse inherited_ifaces) , attrs) decls <- propagateAttributes attrs (foldM desugarDefn [] defs) let core_decls = inherited_decls ++ reverse decls iface = Core.Interface (mkId iface_nm nm home_mod attrs) False inherited_ifaces core_decls addToIfaceEnv nm iface setFilename mod return (iface : acc) where expandIface iface = do mb_decls <- lookupIface iface case mb_decls of Nothing -> do res <- lookupType iface case res of Just (_,Core.Iface iface_nm home_mod inm [] False _, _) -> return ([], [(setOrigQName inm (mkQualName home_mod iface_nm), adjMethodCount iface_nm 0)]) _ -> do when (iface /= "IDispatch" && iface /= "IUnknown") (addWarning ("failed to find inherited interface: "++ iface ++ " - for interface " ++ nm)) let q_iface_name = case iface of "IUnknown" -> iUnknown "IDispatch" -> iDispatch _ -> mkQualName Nothing iface return ([], [(q_iface_name, adjMethodCount iface 0)]) Just (Core.Interface id _ inhs i_ds) | not optSubtypedInterfacePointers && (Core.idName id /= "IUnknown" && Core.idName id /= "IDispatch") -> do return ( i_ds' , (setOrigQName (Core.idOrigName id) (mkQualName (Core.idModule id) (Core.idName id)) , no_methods):inhs ) | otherwise -> -- want to make sure that we're referring to IUnknown and IDispatch -- in the proper manner, since the marshaling of these are in a sense -- built-in. case Core.idName id of "IDispatch" -> return ([], [(iDispatch, 4),(iUnknown, 3)]) "IUnknown" -> return ([], [(iUnknown, 3)]) _ -> return ( [] , ( setOrigQName (Core.idOrigName id) (mkQualName (Core.idModule id) (Core.idName id)) , no_methods):inhs ) where i_ds' = filter isMethod i_ds no_methods = adjMethodCount (Core.idName id) (length i_ds') adjMethodCount iface_nm no_meths = case iface_nm of "IUnknown" -> 3 "IDispatch" -> 7 _ -> no_meths desugarDefn acc (IDL.Module (IDL.Id nm) decls) = addToPath nm $ do inh_attrs <- getAttributes attrs <- augmentAttributes inh_attrs old_mod <- getFilename let mod = Just (mkHaskellTyConName (dropSuffix (basename nm))) setFilename mod (decls',_) <- propagateAttributes attrs (desugarIncludedDecls nm (Just True) [] decls) setFilename old_mod return (Core.Module (mkId (mkHaskellTyConName nm) nm mod attrs) (reverse decls') : acc) desugarDefn acc (IDL.Library (IDL.Id nm) decls) = addToPath nm $ do inh_attrs <- getAttributes attrs <- augmentAttributes inh_attrs old_mod <- getFilename let mod = Just (mkHaskellTyConName (dropSuffix (basename nm))) -- Hack to make sure we don't depend on the older stdole. -- Ugly, but a win from the user's point of view if we -- take care of this. the_mod = case fmap (map toLower) old_mod of Just "stdole32" -> Just "Stdole32" Just "stdole2" -> Just "Stdole32" _ -> mod setFilename the_mod decls' <- inLibrary (propagateAttributes attrs (foldM desugarDefn [] decls)) setFilename old_mod return (Core.Library (mkId (mkHaskellTyConName nm) nm Nothing attrs) (reverse decls') : acc) desugarDefn acc (IDL.CoClass (IDL.Id nm) decls) = addToPath nm $ do inh_attrs <- getAttributes attrs <- augmentAttributes inh_attrs core_decls <- propagateAttributes attrs (mapM desugarCoClassMember decls) mod <- getFilename return (Core.CoClass (mkId nm nm mod attrs) core_decls : acc) desugarDefn acc (IDL.DispInterface (IDL.Id nm) props meths) | optIgnoreDispInterfaces = return acc | otherwise = addToPath nm $ do inh_attrs <- getAttributes attrs <- augmentAttributes inh_attrs old_nm <- getFilename when optOneModulePerInterface (setFilename (Just nm) ) -- Insert a typedef that says that the interface name is an interface, so -- that interface pointers can be marshalled properly. withInterface nm $ do let home_mod | optOneModulePerInterface = Just nm | otherwise = old_nm addToTypeEnv nm home_mod (Core.Iface nm home_mod nm [] True [(iUnknown,3),(iDispatch,4)], attrs) (core_props, core_meths) <- propagateAttributes attrs $ do ps <- mapM desugarProp props ms <- foldM desugarDefn [] meths return (ps, reverse ms) setFilename old_nm let iface = Core.DispInterface (mkId nm nm home_mod attrs) Nothing core_props core_meths addToIfaceEnv nm iface return (iface : acc) desugarDefn acc (IDL.DispInterfaceDecl (IDL.Id nm) (IDL.Id i_nm)) = do mb_iface <- lookupIface i_nm case mb_iface of Just d@(Core.Interface _ _ _ i_ds) -> do attrs <- getAttributes home_mod <- getFilename -- let d_ds = map toDispInterfaceMethod i_ds addToTypeEnv nm home_mod (Core.Iface nm home_mod nm [] True [(iUnknown,3),(iDispatch,4)], attrs) let iface = Core.DispInterface (mkId nm nm home_mod attrs) (Just d) [] (if optServer && optUseStdDispatch then i_ds else []) --i_ds addToIfaceEnv nm iface return (iface : acc) _-> do addWarning ("desugarDefn.DispInterfaceDecl: failed to find interface " ++ show i_nm) return acc desugarDefn acc (IDL.Exception _ _) = do addWarning ("desugarDefn: Exception not handled") return acc desugarDefn acc (IDL.Forward (IDL.Id nm)) = do attrs <- getAttributes mod <- getFilename let iface_nm | optJNI = mkHaskellTyConName (snd (splitLast "." nm)) | otherwise = nm home_mod | optOneModulePerInterface = Just iface_nm | otherwise = mod inherit | optCorba = [(cObject,0)] | otherwise = [] addToTypeEnv nm home_mod (Core.Iface iface_nm home_mod nm [] False inherit, attrs) flg <- isInLibrary if flg then do mb_iface <- lookupIface nm case mb_iface of Nothing -> return acc -- warn? Just (Core.Interface i _ inhs ds) -> return (Core.Interface i True inhs ds : acc) else return acc desugarDefn acc (IDL.Import ls) = do -- store the imported entities away in the various environments we're carrying. old_nm <- getFilename openUpScope $ (if (isJust old_nm) then inImportedContext else id) (sequence (map (\ (nm,ds) -> do let the_nm = dropSuffix nm nm_to_use <- nameOfImport the_nm setFilename (Just nm_to_use) src <- getSrcFilename addToPath the_nm $ desugarer src ds) ls)) setFilename old_nm return acc desugarDefn acc (IDL.ImportLib nm) | not optIgnoreImpLibs = do old_nm <- getFilename let nm' = dropSuffix (basename nm) -- We only set the filename, if it hasn't been set before -- i.e., we're not processing a toplevel declaration. nm_to_use <- nameOfImport nm' when (isJust old_nm) (setFilename (Just nm_to_use)) d <- ioToDsM (importLib nm) when (dumpIDL && optVerbose) (ioToDsM (putStrLn (showIDL (ppDefn d)))) ls <- addToPath nm' $ openUpScope $ (if (isJust old_nm) || not optTlb then inImportedContext else id) (foldM desugarDefn acc [d]) setFilename old_nm if (isJust old_nm) then return acc else return ls | otherwise = do addWarning ("desugarDefn: ignoring importlib("++show nm++");\n Type library imports (via importlib) not handled yet") return acc desugarDefn acc (IDL.Pragma str) = do handlePackPragma (dropWhile isSpace str) return acc desugarDefn acc (IDL.CppQuote str) = return (Core.CLiteral str : acc) desugarDefn acc (IDL.HsQuote str) = return (Core.HsLiteral str : acc) desugarDefn acc (IDL.CInclude s) = return (Core.CInclude s : acc) desugarDefn acc IDL.IncludeStart{} = return acc -- shouldn't occur, but no harm done. desugarDefn acc IDL.IncludeEnd = return acc -- shouldn't occur, but no harm done. \end{code} \begin{code} desugarProp :: ([IDL.Attribute], IDL.Type, IDL.Id) -> DsM Core.Decl desugarProp (attrs, ty, i) = addToPath (iName i) $ do core_attrs <- idlToCoreAttributes (attrs ++ idAttrs i) (nm, core_ty, real_ty) <- mkCoreIdTy ty i True [] home_mod <- getFilename let prop_i = mkId nm (iName i) home_mod core_attrs set_i = prop_i{ Core.idName="set" ++ mkHaskellTyConName (Core.idName prop_i) , Core.idOrigName="set" ++ mkHaskellTyConName (Core.idOrigName prop_i) } get_i = prop_i{ Core.idName="get" ++ mkHaskellTyConName (Core.idName prop_i) , Core.idOrigName="get" ++ mkHaskellTyConName (Core.idOrigName prop_i) } return (Core.Property prop_i core_ty Nothing set_i get_i ) desugarCoClassMember :: IDL.CoClassMember -> DsM Core.CoClassDecl desugarCoClassMember (isInterface, IDL.Id nm, attrs) = addToPath nm $ do core_attrs <- idlToCoreAttributes attrs when (hasSourceAttribute core_attrs) (addSourceIface nm) home_mod <- getFilename mb_iface <- lookupIface nm let attrs_to_pin_on = core_attrs ++ case mb_iface of Just d -> Core.idAttributes (Core.declId d) _ -> [] i = mkId nm nm the_mod attrs_to_pin_on the_mod = case mb_iface of Just (Core.Interface{Core.declId=ii}) -> Core.idModule ii Just (Core.DispInterface{Core.declId=ii}) -> Core.idModule ii _ -> home_mod if isInterface then return (Core.CoClassInterface i mb_iface) else return (Core.CoClassDispInterface i mb_iface) \end{code} \begin{code} mkCoreIdTy :: IDL.Type -> IDL.Id -> Bool -> [Core.Attribute] -> DsM (String, Core.Type, Core.Type) mkCoreIdTy ty i isTopLev attrs = do (n,t) <- mkCoreIdTy' ty' i' isTopLev attrs return (n, t, normaliseType t) where (qual, ty') = getTyQual ty i' = case (prec i) of IDL.Pointed ([]:qs) pi -> IDL.Pointed (qual:qs) pi oi -> oi -- ToDo: implement precedences properly. prec (IDL.Pointed q pi) = prec1 (IDL.Pointed q) pi prec (IDL.ArrayId ai es) = prec2 (\ z -> IDL.ArrayId z es) ai prec pi = pi prec1 cont (IDL.ArrayId ai es) = prec1 (\ x -> IDL.ArrayId (cont x) es) ai prec1 cont pi = cont pi prec2 cont (IDL.Pointed q pi) = prec2 (\ x -> IDL.Pointed q (cont x)) pi prec2 cont pi = cont pi mkCoreIdTy' :: IDL.Type -> IDL.Id -> Bool -> [Core.Attribute] -> DsM (String, Core.Type) mkCoreIdTy' ty (IDL.Id nm) _ attrs = do as <- getAttributes real_ty <- withAttributes (attrs ++ as) (idlToCoreTy ty) return (nm, {-core_ty,-} real_ty) mkCoreIdTy' ty (IDL.AttrId as i) isTopLev attrs = do core_as <- idlToCoreAttributes as mkCoreIdTy' ty i isTopLev (core_as ++ attrs) mkCoreIdTy' ty (IDL.CConvId _ i) isTopLev attrs = mkCoreIdTy' ty i isTopLev attrs mkCoreIdTy' ty (IDL.ArrayId i es) _ attrs = do (nm, core_ty) <- mkCoreIdTy' ty i False attrs core_exprs <- mapM idlToCoreExpr es cenv <- getConstEnv let core_exprs' = map (simpRedExpr cenv intTy) core_exprs return (nm, {-Core.Array core_ty core_exprs,-} Core.Array core_ty core_exprs') mkCoreIdTy' ty (IDL.Pointed quals i) isTopLev local_attrs = do (nm, real_ty) <- mkCoreIdTy' ty i False local_attrs let ty_nm = showCore (ppType (removePtr real_ty)) core_ty <- mkPointer ty_nm real_ty quals -- orig_ty <- mkPointer ty_nm orig_ty' quals return (nm, core_ty) --, orig_ty) where {- + toplevel pointer receives its pointer attribute from its local attributes. + [string] is handled specially, it applies to the innermost (char) pointer. -} mkPointer _ tty [] = return tty mkPointer nm tty ls@(x:xs) | hasStringAttribute local_attrs = mkStringTy nm tty ls | hasSeqAttribute local_attrs = do let mb_expr = case getLengthAttribute local_attrs of Just (Core.ParamLit l) -> Just (Core.Lit l) Just (Core.ParamExpr e) -> Just e Just (Core.ParamVar v) -> Just (Core.Var v) _ -> Nothing mb_term = case findAttribute "terminator" local_attrs of Just (Core.Attribute _ (ap:_)) -> case ap of Core.ParamLit l -> Just (Core.Lit l) Core.ParamExpr e -> Just e Core.ParamVar v -> Just (Core.Var v) _ -> Nothing _ -> Nothing core_ty <- foldM (mkPtr nm) tty xs return (Core.Sequence core_ty mb_expr mb_term) | otherwise = do let attrs_to_use = case x of (Const:_) -> local_attrs ++ [Core.Attribute "ref" []] (Volatile:_) -> local_attrs ++ [Core.Attribute "ptr" []] _ -> local_attrs core_ty <- foldM (mkPtr nm) tty xs return ((findPtrType isTopLev attrs_to_use) core_ty) mkStringTy _ tty [] = return tty mkStringTy _ tty [_] | normaliseType tty == Core.WChar = return (Core.WString (hasUniqueAttribute local_attrs) Nothing) | otherwise = return (Core.String tty --(Core.Char False) (hasUniqueAttribute local_attrs) Nothing) mkStringTy nm tty (x:xs) = do ty' <- mkStringTy nm tty xs mkPtr nm ty' x {- assigning the right pointer type goes as follows: * if type definition specifies a pointer type (this includes its definition context) - use it. * if the current attribute context specifies one - use it. * if all of the above fails, use *ref* for parameters, and *unique* for fields/ function results. -} mkPtr nm tty [] = do mb_res <- lookupType nm case mb_res of Just (_,_,attrs) -> return ((findPtrType False attrs) tty) Nothing -> findDef tty {- Note: if you specify typedef const const volatile const volatile int* foo; you'll get a const (aka ref) pointer, i.e., leftmost qualifier overrides whatever comes after. -} mkPtr _ acc (Const:_) = return (Core.Pointer Ref True acc) mkPtr _ acc (_:_) = return (Core.Pointer Ptr True acc) findDef t = do attrs <- getAttributes return ((findPtrType False attrs) t) mkCoreIdTy' ty (IDL.FunId i mb_cc params) isTopLev attrs = do (nm,core_ty) <- mkCoreIdTy' ty i isTopLev attrs core_params <- idlToCoreParams (iName i) params let cc = fromMaybe defaultCConv mb_cc let t = Core.FunTy cc (Core.Result (normaliseType core_ty) core_ty) core_params return ( nm, t) \end{code} \begin{code} idlToCoreParams :: String -> [IDL.Param] -> DsM [Core.Param] idlToCoreParams meth ps = zipWithM (idlToCoreParam meth) [(1::Int)..] ps idlToCoreParam :: String -> Int -> IDL.Param -> DsM Core.Param idlToCoreParam meth idx (IDL.Param i ty attrs) = -- We allow either the use of "arg" or the parameter name here, -- so hackily we check whether the first alt. is in scope, before -- plumping for the second. -- let configPath d | optUseAsfs = do ls <- getPath let alt1 = "arg" ++ show idx res <- lookupAsf (ls ++ '.':alt1) if (isJust res) then addToPath alt1 d else addToPath (iName i) d | otherwise = d in configPath $ do core_attrs <- idlToCoreAttributes attrs let withIn = hasModeAttribute In core_attrs withOut = hasModeAttribute Out core_attrs withInOut = hasModeAttribute InOut core_attrs || (withIn && withOut) core_attrs2 | withOut && not withInOut && optOutPointersAreRefs = (Core.Attribute "ref" []):core_attrs -- toplevel pointers | otherwise = core_attrs (p_ty, p_i) = movePointers ty i (nm, core_ty, real_ty) <- mkCoreIdTy p_ty p_i True core_attrs2 mb_if <- getInterface let if_prefix x = case mb_if of Nothing -> meth ++ '.':x Just y -> y ++ '.':meth ++ '.':x {- Defaulting the parameter mode and type. -} (mode, real_ty', core_ty') | withInOut = (InOut, real_ty, core_ty) | withOut = case real_ty of Core.Pointer _ _ (Core.Pointer _ _ Core.Void) | core_attrs `hasAttributeWithName` "iid_is" -> -- normalise double-pointed out args with iid_is(); ignore -- the supplied pointer modifiers and insist on ref-ref. ( Out , Core.Pointer Ref True (Core.Pointer Ref True iUnknownTy) , mkRefPointer (rawPointerToIP core_ty) ) Core.Pointer pt isExp t -- insist on a [ref] here. | optOutPointersAreRefs -> (Out, Core.Pointer Ref isExp t', mkRefPointer c_ty') | otherwise -> (Out, Core.Pointer pt isExp t', core_ty) where (t', c_ty') -- we insist that out i-pointers are {r}*{r}*. | isIfacePtr t = (Core.Pointer Ref isExp (getIfaceTy t), Core.Pointer Ref isExp (getIfaceTy core_ty)) | otherwise = (t, core_ty) _ | optCompilingOmgIDL -> (Out, Core.Pointer Ref True real_ty, mkRefPointer core_ty) | otherwise -> (Out, real_ty, core_ty) | withIn = (In, real_ty, core_ty) | optVerbose && not optNoWarnMissingMode = trace ("Warning: no mode for parameter " ++ show (if_prefix (iName i)) ++ " (defaulting it to [in].)") (In, real_ty, core_ty) | otherwise = (In, real_ty, core_ty) is_dependent = hasDependentAttrs core_attrs2 {- Duplicating the default'ed parameter mode in the attribute list makes it possible to pretty print a param without looking at its mode field. -} core_attrs_final | not (withIn || withOut || withInOut) = (Core.AttrMode mode:core_attrs2) | otherwise = core_attrs2 core_param = Core.Param (mkId nm (iName i) Nothing core_attrs_final) mode real_ty' core_ty' is_dependent return (validateParam (if_prefix (iName i)) core_param) movePointers :: IDL.Type -> IDL.Id -> (IDL.Type, IDL.Id) movePointers (IDL.TyPointer t) i = movePointers t (IDL.Pointed [[]] i) movePointers t i = (t,i) \end{code} Having a front end type representation that differs slightly from the intermediate rep., is somewhat tedious. \begin{code} idlToCoreTy :: IDL.Type -> DsM Core.Type idlToCoreTy ty = case ty of IDL.TyInteger sz -> return (Core.Integer sz True) IDL.TyFloat sz -> return (Core.Float sz) IDL.TyStable -> return (Core.StablePtr) IDL.TyChar -> return (Core.Char False) IDL.TyWChar -> return (Core.WChar) IDL.TyBool -> return (Core.Bool) IDL.TyOctet -> return (Core.Octet) IDL.TyAny -> return (Core.Any) IDL.TyObject | optJNI -> return (Core.Iface "JObject" jniLib "java.lang.Object" [] False []) | otherwise -> return Core.Object IDL.TyBString -> return bstrTy IDL.TyFun mb_cc r_ty ps -> do core_ps <- idlToCoreParams "" ps res_ty <- idlToCoreTy r_ty let cc = fromMaybe defaultCConv mb_cc return (Core.FunTy cc (Core.Result (normaliseType res_ty) res_ty) core_ps) IDL.TyVoid -> return (Core.Void) IDL.TyIface nm -> case nm of "IUnknown" -> return iUnknownTy "IDispatch" -> return iDispatchTy _ -> do -- attribute right module for where the type was defined. -- Don't reduce the type here. res <- lookupType nm let inherit | optCorba = [(cObject,0)] | otherwise = [] attrs <- getAttributes case res of Nothing -> return (Core.Iface nm Nothing nm attrs False inherit) Just (_, tty, _) -> return tty IDL.TyName "java.lang.String" _ | optJNI -> return (Core.String (Core.Char False) False Nothing) IDL.TyName nm mb_t -> do -- attribute it with the module where the type was defined. -- Don't reduce the type here, wait until the cleanup/renaming pass. let (qual, ty_nm) | optCompilingOmgIDL = splitLast "::" nm | otherwise = ([], nm) mb_mod = toMaybe null qual res <- do r <- lookupType ty_nm case r of Nothing -> lookupType nm Just _ -> return r as <- getAttributes case res of Nothing -> do mb_ti <- lookupTypeInfo ty_nm case mb_t of Nothing | optJNI -> case splitLast "." ty_nm of (bef,aft) | notNull bef -> do -- strong indication of an object type, repr. it as an Iface. attrs <- getAttributes let iface_nm = mkHaskellTyConName aft case ty_nm of -- JNI lib has got special support for Strings. "java.lang.String" -> return (Core.String (Core.Char False) False Nothing) _ -> return (Core.Iface iface_nm (Just iface_nm) ty_nm attrs False [(jObject,0)]) | otherwise -> return (Core.Name ty_nm ty_nm mb_mod Nothing Nothing mb_ti) | otherwise -> do tg <- lookupTag nm case tg of Nothing -> return (Core.Name ty_nm ty_nm mb_mod Nothing Nothing mb_ti) Just (mod1,v) -> return (Core.Name v v mod1 Nothing Nothing mb_ti) Just it -> do ot <- idlToCoreTy it case ot of Core.Iface inm mod _ attrs is_idis inh | inm == ty_nm || optJNI -> return (Core.Iface inm mod ty_nm (attrs ++ as) is_idis inh) -- return (Core.Iface aft (Just aft) ty_nm (attrs ++ as) is_idis inh) -- rid ourselves of compiler introduced synonyms, if -- they just refer to another name. Core.Name{} | "IHC_TAG" `isPrefixOf` ty_nm -> return ot | "__IHC_TAG" `isPrefixOf` ty_nm -> return ot _ -> return (Core.Name ty_nm ty_nm mb_mod (Just as) (Just ot) mb_ti) Just (mod, tty, attrs) -> -- Avoid creating (Name nm (Iface nm ..)) case tty of Core.Iface "IUnknown" _ _ _ _ _ -> return iUnknownTy -- sigh. Core.Iface "IDispatch" _ _ _ _ _ -> return iDispatchTy Core.Iface "String" (Just _) _ _ _ _ | optJNI -> return (Core.String (Core.Char False) False Nothing) Core.Iface inm imod tnm iattrs is_idis inh | optJNI || inm == ty_nm -> do return (Core.Iface inm imod tnm (iattrs ++ ty_attrs) is_idis inh) Core.Name _ _ _ _ _ mb_ti | "IHC_TAG" `isPrefixOf` ty_nm -> return tty | "__IHC_TAG" `isPrefixOf` ty_nm -> return tty | otherwise -> return (Core.Name ty_nm ty_nm mod (Just ty_attrs) the_ty mb_ti) _ -> return (Core.Name ty_nm ty_nm mod (Just ty_attrs) the_ty Nothing) where the_ty = Just tty ty_attrs = attrs ++ as IDL.TyPointer (IDL.TyName "wchar_t" Nothing) -> do return (Core.WString False Nothing) IDL.TyPointer t -> do core_ty <- idlToCoreTy t return (Core.Pointer Ref True core_ty) {- IDL.TyFixed e i -> do core_expr <- idlToCoreExpr e return (Core.Fixed core_expr i) -} IDL.TyArray t es -> do core_ty <- idlToCoreTy t core_es <- mapM idlToCoreExpr es cenv <- getConstEnv let core_exprs = map (simpRedExpr cenv intTy) core_es return (Core.Array core_ty core_exprs) IDL.TySafeArray t -> do core_ty <- idlToCoreTy t return (Core.SafeArray core_ty) IDL.TyApply (IDL.TySigned s) (IDL.TyInteger sz) -> return (Core.Integer sz s) IDL.TyApply (IDL.TySigned s) IDL.TyChar -> return (Core.Char s) IDL.TyApply (IDL.TySigned s) t -> do t' <- idlToCoreTy t case t' of Core.Name _ _ _ _ (Just (Core.Integer i _)) _ -> return (Core.Integer i s) _ -> return (Core.Integer Long s) IDL.TySigned s -> return (Core.Integer Long s) IDL.TyApply (IDL.TyQualifier _) t -> idlToCoreTy t IDL.TyApply t (IDL.TyQualifier _) -> idlToCoreTy t IDL.TyString mb_expr -> do core_expr <- mapFromMb (return Nothing) ((mapDsM Just) . idlToCoreExpr) mb_expr cenv <- getConstEnv let core_expr' = fmap (simpRedExpr cenv intTy) core_expr return (Core.String (Core.Char False) False core_expr') IDL.TyWString mb_expr -> do core_expr <- mapFromMb (return Nothing) ((mapDsM Just) . idlToCoreExpr) mb_expr cenv <- getConstEnv let core_expr' = fmap (simpRedExpr cenv intTy) core_expr return (Core.WString False core_expr') IDL.TySequence t mb_expr -> do core_ty <- idlToCoreTy t core_expr <- mapFromMb (return Nothing) ((mapDsM Just) . idlToCoreExpr) mb_expr cenv <- getConstEnv let core_expr' = fmap (simpRedExpr cenv intTy) core_expr return (Core.Sequence core_ty core_expr' Nothing) -- the rest of the IDL.Type constructors have optional -- (Maybe-valued) fields - we here assume that a previous -- pass have filled these fields in with a value. -- an enum-reference; lookup real type in environment IDL.TyEnum (Just (IDL.Id nm)) [] -> do res <- lookupType nm attrs <- getAttributes home_mod <- getFilename case res of Nothing -> return (Core.Enum (mkId nm nm Nothing attrs) Unclassified []) Just (_,core_ty, _) -> idlToCoreTy (IDL.TyName (Core.idName (getTyTag core_ty)) Nothing) IDL.TyEnum (Just (IDL.Id nm)) enums -> do core_enums <- fillInEnums (Left (0::Int32)) enums attrs <- getAttributes home_mod <- getFilename let {- Try to characterise the enumeration sequence as being an instance of a kind that's easy to generate code for in the end (e.g., if the tags start from zero and inc. by one, we can use Haskell's "deriving" mechanism to generate enum <--> Int mappings. -} kind | not (isJust mb_tags) = Unclassified | otherwise = classifyProgression (sort tags) mb_tags = getEnumTags [] core_enums (Just tags) = mb_tags core_enums_to_use | isJust mb_tags = sortBy cmpTag core_enums | otherwise = core_enums cmpTag (Core.EnumValue _ (Left t1)) (Core.EnumValue _ (Left t2)) = compare t1 t2 getEnumTags acc [] = Just (reverse acc) getEnumTags acc ((Core.EnumValue _ (Left x)):xs) = getEnumTags (x:acc) xs getEnumTags _ _ = Nothing return (Core.Enum (mkId nm nm home_mod attrs) kind core_enums_to_use) where fillInEnums _ [] = return [] fillInEnums n ((IDL.Id tnm, attrs, Nothing):xs) = do addToConstEnv tnm n ls <- fillInEnums (addOne n) xs inh_attrs <- getAttributes core_attrs <- idlToCoreAttributes attrs home_mod <- getFilename return ((Core.EnumValue (mkId tnm tnm home_mod (core_attrs ++ inh_attrs)) n) : ls) fillInEnums _ ((IDL.Id tnm, attrs, Just e):xs) = do n' <- reduceExpr (idlToCoreTy) e addToConstEnv tnm n' inh_attrs <- getAttributes core_attrs <- idlToCoreAttributes attrs home_mod <- getFilename ls <- fillInEnums (addOne n') xs return ((Core.EnumValue (mkId tnm tnm home_mod (core_attrs ++ inh_attrs)) n'): ls) addOne (Left n) = Left (n+1) addOne (Right e) = Right (Core.Binary Add e (Core.Lit (iLit (1::Int)))) IDL.TyStruct (Just (IDL.Id nm)) [] mb_packed -> do tg <- lookupTag nm case tg of Just (_,v) -> idlToCoreTy (IDL.TyName v Nothing) Nothing -> do attrs <- getAttributes home_mod <- getFilename mb_pck <- getCurrentPack return (Core.Struct (mkId nm nm home_mod attrs) [] (mb_packed `mplus` mb_pck)) IDL.TyStruct (Just (IDL.Id _)) [(t,_,[i])] _ | optUnwrapSingletonStructs && not (isAnonTy t) -> idlToCoreTy (transferPointedness i t) IDL.TyStruct (Just (IDL.Id nm)) mems mb_packed -> do core_mems <- mapM memberToField mems attrs <- getAttributes home_mod <- getFilename mb_pck <- getCurrentPack return (Core.Struct (mkId nm nm home_mod attrs) (concat core_mems) (mb_packed `mplus` mb_pck)) IDL.TyUnion (Just (IDL.Id nm1)) t (IDL.Id nm2) (Just (IDL.Id nm3)) switches -> do core_ty <- idlToCoreTy t core_sw <- idlToCoreSwitches switches attrs <- getAttributes home_mod <- getFilename return (Core.Union (mkId nm1 nm1 home_mod attrs) core_ty (mkId nm2 nm2 home_mod attrs) (mkId nm3 nm3 home_mod attrs) core_sw) IDL.TyUnionNon (Just (IDL.Id nm1)) switches -> do core_sw <- idlToCoreSwitches switches attrs <- getAttributes home_mod <- getFilename return (Core.UnionNon (mkId nm1 nm1 home_mod attrs) core_sw) -- a union-reference; lookup real type in environment IDL.TyCUnion (Just (IDL.Id nm)) [] mb_pack -> do res <- lookupType nm attrs <- getAttributes case res of Just (_,core_ty, _) -> return core_ty Nothing -> do home_mod <- getFilename mb_pck <- getCurrentPack return (Core.CUnion (mkId nm nm home_mod attrs) [] (mb_pack `mplus` mb_pck)) IDL.TyCUnion (Just (IDL.Id nm1)) members mb_pack -> do core_mems <- mapM memberToField members attrs <- getAttributes home_mod <- getFilename mb_pck <- getCurrentPack return (Core.CUnion (mkId nm1 nm1 home_mod attrs) (concat core_mems) (mb_pack `mplus` mb_pck)) _ -> error ("idlToCoreTy: " ++ showIDL (PpIDL.ppType ty)) \end{code} \begin{code} memberToField :: IDL.Member -> DsM [Core.Field] memberToField (ty, attrs, ids) = do core_attrs <- idlToCoreAttributes attrs home_mod <- getFilename let mkCoreField i = do let (f_ty, f_i, mb_sz) = case (movePointers ty i) of (t, IDL.BitFieldId x bi) -> (t, bi, Just x) (t,fi) -> (t,fi,Nothing) (nm, orig_ty, core_ty) <- mkCoreIdTy f_ty f_i False core_attrs as <- getAttributes let as2 = core_attrs ++ as return (Core.Field (mkId nm nm home_mod as2) core_ty orig_ty mb_sz Nothing) mapM mkCoreField ids idlToCoreSwitches :: [IDL.Switch] -> DsM [Core.Switch] idlToCoreSwitches switches = mapM idlToCoreSwitch switches {- Since switches contain types and expressions, we cannot share the Switch type between Core and IDL. -} idlToCoreSwitch :: IDL.Switch -> DsM Core.Switch idlToCoreSwitch (IDL.Switch labs (Just (IDL.Param i ty attrs))) = addToPath (iName i) $ do core_attrs <- idlToCoreAttributes attrs (nm, orig_ty, core_ty) <- mkCoreIdTy ty i False core_attrs as <- getAttributes let as2 = core_attrs ++ as core_labs <- mapM idlToCoreCaseLabel labs home_mod <- getFilename return (Core.Switch (mkId nm (iName i) home_mod as2) (concat core_labs) core_ty orig_ty ) idlToCoreSwitch (IDL.Switch [IDL.Default] Nothing) = return (Core.SwitchEmpty Nothing) idlToCoreSwitch (IDL.Switch labs Nothing) = do core_labs <- mapM idlToCoreCaseLabel labs let tg_names = concatMap toLabel labs return (Core.SwitchEmpty (Just (zip (concat core_labs) tg_names))) where toLabel IDL.Default = ["Anon"] -- good enough? toLabel (IDL.Case es) = map exprToName es idlToCoreCaseLabel :: IDL.CaseLabel -> DsM [Core.CaseLabel] idlToCoreCaseLabel IDL.Default = return [Core.Default] idlToCoreCaseLabel (IDL.Case es) = mapM (\ e -> do core_e <- idlToCoreExpr e cenv <- getConstEnv let core_expr = simpRedExpr cenv intTy core_e return (Core.Case core_expr)) es \end{code} %* % \section[expr]{Converting expressions} % %* The only difference between @IDL.Expr@ and @Core.Expr@ is that they use different @Type@ types. \begin{code} idlToCoreExpr :: IDL.Expr -> DsM Core.Expr idlToCoreExpr e = case e of IDL.Binary bop e1 e2 -> do c1 <- idlToCoreExpr e1 c2 <- idlToCoreExpr e2 return (Core.Binary bop c1 c2) IDL.Cond e1 e2 e3 -> do c1 <- idlToCoreExpr e1 c2 <- idlToCoreExpr e2 c3 <- idlToCoreExpr e3 return (Core.Cond c1 c2 c3) IDL.Unary op e1 -> do c <- idlToCoreExpr e1 return (Core.Unary op c) IDL.Var nm -> do res <- lookupConst nm case res of Nothing -> return (Core.Var nm) Just (Left v) -> return (Core.Lit (iLit v)) Just (Right e1) -> return e1 IDL.Lit l -> return (Core.Lit l) IDL.Cast t e1 -> do core_t <- idlToCoreTy t c <- idlToCoreExpr e1 return (Core.Cast (normaliseType core_t) c) IDL.Sizeof t -> do core_t <- idlToCoreTy t return (Core.Sizeof (normaliseType core_t)) \end{code} %* % \subsection{Filling in} % %* Before translating into the core syntax, we fill in the tags and Ids that are optional. \begin{code} fillInDefn :: IDL.Defn -> NSM [IDL.Defn] fillInDefn def = case def of IDL.Typedef ty attrs ids -> do let withName = case ids of (IDL.Id s : _) -> withTyTag s _ -> id (ty', ds1) <- fillInType (withName ty) (ty'', ds) <- simplifyType False attrs ty' {- put the (type) declarations that have been lifted out of ty' before the typedef itself, so that they're in scope when processing it later. (Note: this isn't sufficient to deal with recursive defns.) -} let ids' = map massageId ids return (ds1 ++ ds ++ [IDL.Typedef ty'' attrs ids']) IDL.TypeDecl ty -> do (ty', ds1) <- fillInType ty (ty'', ds) <- simplifyType False [] ty' return (ds1 ++ ds ++ [IDL.TypeDecl ty'']) IDL.Constant i attrs ty e -> do (ty',ds1) <- fillInType ty return (ds1 ++ [IDL.Constant i attrs ty' e]) IDL.Attributed attrs d -> do ds' <- fillInDefn d return (map (IDL.Attributed attrs) ds') IDL.Attribute ids read_only ty -> do (ty',ds) <- fillInType ty let ids' = map massageId ids return (ds ++ [IDL.Attribute ids' read_only ty']) IDL.Operation i ty mb_raise mb_context -> do (ty',ds1) <- fillInType ty let i' = massageId i (fi,ds) <- fillInFunId i' return (ds1 ++ ds ++ [IDL.Operation fi ty' mb_raise mb_context]) IDL.Interface i inherit defs -> do defs' <- mapM fillInDefn defs return [IDL.Interface i inherit (concat defs')] IDL.Module i defs -> do defs' <- mapM fillInDefn defs return [IDL.Module i (concat defs')] IDL.Library i defs -> do defs' <- mapM fillInDefn defs return [IDL.Library i (concat defs')] IDL.ExternDecl ty [i] | optHaskellToC -> do let i' = massageId i fillInDefn (IDL.Operation i' ty Nothing Nothing) IDL.DispInterface i props meths -> do meths' <- mapM fillInDefn meths return [IDL.DispInterface i props (concat meths')] _ -> return [def] {- "foo(void)" is the same as "foo()" - spot this here rather than in the parser, and remove the "void" -} removeVoidParam :: [IDL.Param] -> [IDL.Param] removeVoidParam [IDL.Param (IDL.Id "") IDL.TyVoid _] = [] removeVoidParam ps = ps fillInFunId :: IDL.Id -> NSM (IDL.Id, [IDL.Defn]) fillInFunId (IDL.FunId i mb_cc ps) = do let ps1 = removeVoidParam ps -- lift out non-trivial arguments from parameter positions -- and create typedefs for them. Needed to marshall them properly. stuff <- zipWithM fillInParam ps1 [(1::Int)..] let (ps2, dss) = unzip stuff return (IDL.FunId i mb_cc ps2, concat dss) fillInFunId i = return (i,[]) fillInParam :: IDL.Param -> Int -> NSM (IDL.Param, [IDL.Defn]) fillInParam (IDL.Param i ty attrs) x = do (i', ty', ds) <- fillInParamId i return (IDL.Param i' ty' attrs, ds) where fillInParamId (IDL.Id "") = return (IDL.Id ("arg"++show x), ty, []) fillInParamId pi@(IDL.Id _) = return (pi, ty, []) fillInParamId (IDL.AttrId as ai) = do (ai', ty', ds) <- fillInParamId ai return (IDL.AttrId as ai', ty', ds) fillInParamId pi@(IDL.ArrayId _ _) = return (pi, ty, []) fillInParamId (IDL.CConvId cc ci) = do (i', ty', ds) <- fillInParamId ci return (IDL.CConvId cc i', ty', ds) -- just ignore CConvIds here. fillInParamId (IDL.BitFieldId _ bi) = fillInParamId bi fillInParamId (IDL.Pointed qs pi) = do (i', ty', ds) <- fillInParamId pi return (IDL.Pointed qs i', ty', ds) fillInParamId (IDL.FunId fi cc_i ps) = do let ps1 = removeVoidParam ps stuff <- zipWithM fillInParam ps1 [(1::Int)..] let (ps2, dss) = unzip stuff (i', ty', ds) <- fillInParamId fi new_nm <- getNewName let new_def = [IDL.Typedef (IDL.TyFun cc_i ty' ps2) [] [IDL.Id new_nm] ] return (i', IDL.TyName new_nm Nothing, ds ++ concat dss++ new_def) -- The enum, struct and union constructors may have optional -- fields. fillInType decorates them. -- -- ToDo: document the naming strategy. -- -- The reason why we're floating out a bunch of defns too in -- the result of 'fillInType' is that for function types we -- have to introduce a 'typedef' in order to generate marshalling -- code for it. A lot of plumbing for a not-too-common case. -- ToDo: consider separating the hoisting of 'FunIds' into a -- separate pass. -- fillInType :: IDL.Type -> NSM (IDL.Type, [IDL.Defn]) fillInType ty = case ty of IDL.TyPointer t -> do (t',ds) <- fillInType t return (IDL.TyPointer t', ds) IDL.TyArray t es -> do (t',ds) <- fillInType t return (IDL.TyArray t' es, ds) IDL.TyApply f a -> do (f',ds1) <- fillInType f (a',ds2) <- fillInType a return (IDL.TyApply f' a', ds1 ++ ds2) IDL.TySequence t mb_expr -> do (t',ds1) <- fillInType t return (IDL.TySequence t' mb_expr, ds1) IDL.TyEnum mb_id enums -> do id <- case mb_id of Just _ -> return mb_id Nothing -> mapNSM (Just . (IDL.Id)) getNewName return (IDL.TyEnum id enums, []) IDL.TyStruct mb_tag structs mb_pack -> do tag <- case mb_tag of Just (IDL.Id v) -> return (Just (IDL.Id v)) Nothing -> mapNSM (Just . (IDL.Id)) (getNewName) stuff <- mapM fillInMember structs let (structs', dss) = unzip stuff return (IDL.TyStruct tag structs' mb_pack, concat dss) IDL.TyUnion mb_tag t switch_tag mb_union_struct_tag switches -> do (t',ds) <- fillInType t tag <- case mb_tag of Just (IDL.Id v) -> return (Just (IDL.Id v)) Nothing -> mapNSM (Just . (IDL.Id)) (getNewName) union_struct_tag <- case mb_union_struct_tag of Just (IDL.Id v) -> return (Just (IDL.Id v)) Nothing -> return (Just (IDL.Id "tagged_union")) -- mimicing MIDL here stuff <- mapM fillInSwitch switches let (switches', dss) = unzip stuff return (IDL.TyUnion tag t' switch_tag union_struct_tag switches', ds ++ concat dss) IDL.TyUnionNon mb_tag switches -> do tag <- case mb_tag of Just (IDL.Id v) -> return (Just (IDL.Id v)) Nothing -> mapNSM (Just . (IDL.Id)) (getNewName) stuff <- mapM fillInSwitch switches let (switches', dss) = unzip stuff return (IDL.TyUnionNon tag switches', concat dss) IDL.TyCUnion mb_tag members mb_pack -> do tag <- case mb_tag of Just (IDL.Id v) -> return (Just (IDL.Id v)) Nothing -> mapNSM (Just . (IDL.Id)) (getNewName) stuff <- mapM fillInMember members let (members', dss) = unzip stuff return (IDL.TyCUnion tag members' mb_pack, concat dss) _ -> return (ty, []) fillInMember :: IDL.Member -> NSM (IDL.Member, [IDL.Defn]) fillInMember (ty, attrs, ids) = do (ty',ds1) <- fillInType ty (is,ds) <- case ids of [] -> do n <- getNewName return ([IDL.Id n], []) _ -> do stuff <- mapM fillInId ids let (is, dss) = unzip stuff return (is, concat dss) return ((ty', attrs, is), ds1 ++ ds) fillInSwitch :: IDL.Switch -> NSM (IDL.Switch, [IDL.Defn]) fillInSwitch (IDL.Switch labs arm) = do (arm', ds) <- fillInArm arm return (IDL.Switch labs arm', ds) fillInArm :: Maybe IDL.SwitchArm -> NSM (Maybe IDL.SwitchArm, [IDL.Defn]) fillInArm Nothing = return (Nothing, []) fillInArm (Just (IDL.Param i ty attr)) = do (ty',ds1) <- fillInType ty (i',ds2) <- fillInId i return (Just (IDL.Param i' ty' attr), ds1 ++ ds2) fillInId :: IDL.Id -> NSM (IDL.Id, [IDL.Defn]) fillInId (IDL.Id "") = do -- ToDo: document exactly when an empty Id can occur. x <- getNewName return (IDL.Id x, []) fillInId i@(IDL.Id _) = return (i, []) fillInId (IDL.AttrId as i) = do (i', ds) <- fillInId i return (IDL.AttrId as i', ds) fillInId (IDL.ArrayId i es) = do (i',ds) <- fillInId i return (IDL.ArrayId i' es, ds) fillInId (IDL.Pointed qs i) = do (i',ds) <- fillInId i return (IDL.Pointed qs i', ds) fillInId (IDL.CConvId c i) = do (i',ds) <- fillInId i return (IDL.CConvId c i', ds) fillInId (IDL.BitFieldId x i) = do (i',ds) <- fillInId i return (IDL.BitFieldId x i', ds) fillInId (IDL.FunId i cc ps) = do let ps1 = removeVoidParam ps stuff <- zipWithM fillInParam ps1 [(1::Int)..] let (ps2, dss) = unzip stuff (i',ds1) <- fillInId i return (IDL.FunId i' cc ps2, ds1 ++ concat dss) \end{code} \begin{code} idlToCoreAttributes :: [IDL.Attribute] -> DsM [Core.Attribute] idlToCoreAttributes attrs = do as <- if not optUseAsfs then return attrs else do pth <- getPath res <- lookupAsf pth return $ case res of Nothing -> attrs Just (False, ss) -> ss Just (_, ss) -> attrs ++ ss mapM idlToCoreAttribute as augmentAttributes :: [Core.Attribute] -> DsM [Core.Attribute] augmentAttributes inh_attrs | not optUseAsfs = return inh_attrs | otherwise = do pth <- getPath res <- lookupAsf pth case res of Nothing -> return inh_attrs Just (False, ss) -> mapM idlToCoreAttribute ss Just (_,ss) -> do ss' <- mapM idlToCoreAttribute ss return (inh_attrs ++ ss') idlToCoreAttribute :: IDL.Attribute -> DsM (Core.Attribute) idlToCoreAttribute (IDL.Mode m) = case m of In -> return (Core.AttrMode m) Out -> return (Core.AttrMode m) InOut -> return (Core.AttrMode m) idlToCoreAttribute (IDL.Attrib i params) = do core_params <- mapM convParam params let nm = iName i mb_reason = stringToDepReason nm attr_con | isJust mb_reason = Core.AttrDependent (fromJust mb_reason) | otherwise = Core.Attribute nm return (attr_con core_params) where convParam (IDL.AttrExpr (IDL.Lit l)) = return (Core.ParamLit l) convParam (IDL.AttrExpr (IDL.Var v)) = do res <- lookupConst v case res of Nothing -> return (Core.ParamVar v) Just (Left v1) -> return (Core.ParamLit (iLit v1)) Just (Right e) -> return (Core.ParamExpr e) convParam (IDL.AttrExpr e) = do core_e <- reduceExpr (\ x -> idlToCoreTy x) e case core_e of Left l -> return (Core.ParamLit (iLit l)) Right e1 -> return (Core.ParamExpr e1) convParam (IDL.EmptyAttr) = return (Core.ParamVoid) convParam (IDL.AttrLit (TypeConst tc)) = do ty <- lookupType tc mb_ti <- lookupTypeInfo tc let t = case ty of Nothing -> Core.Name tc tc Nothing Nothing Nothing mb_ti Just (_,t1,as) -> Core.Name tc tc Nothing (Just as) (Just t1) mb_ti return (Core.ParamType (normaliseType t)) convParam (IDL.AttrLit l) = return (Core.ParamLit l) convParam (IDL.AttrPtr a) = do core_a <- convParam a return (Core.ParamPtr core_a) \end{code} Prior to translation into core, we simplify union and struct types, lifting out any embedded enum/struct/union members they might have. \begin{code} simplifyType :: Bool -> [IDL.Attribute] -> IDL.Type -> NSM (IDL.Type, [IDL.Defn]) simplifyType liftOut attrs ty | liftOut && isConstructedTy ty = do nm <- getNewName (ty', ds) <- simplifyType False [] ty return (IDL.TyName nm (Just ty'), ds ++ [IDL.Typedef ty' attrs [IDL.Id nm]]) | otherwise = case ty of IDL.TyStruct tag mems mb_pack -> do (mems', decls) <- simplifyMembers attrs mems mems let addFwdDecl = id {- case tag of Just i -> ((IDL.Typedef (IDL.TyStruct tag [] Nothing) [] [i]):) _ -> id -} return (IDL.TyStruct tag mems' mb_pack, addFwdDecl decls) IDL.TyUnion tag t switch_tag union_struct_tag switches -> do (switches', decls) <- simplifySwitches switches return (IDL.TyUnion tag t switch_tag union_struct_tag switches', decls) IDL.TyCUnion tag members mb_pack -> do (members', decls) <- simplifyMembers attrs members members return (IDL.TyCUnion tag members' mb_pack, decls) IDL.TyUnionNon tag switches -> do (switches', decls) <- simplifySwitches switches return (IDL.TyUnionNon tag switches', decls) _ -> return (ty, []) simplifyMembers :: [IDL.Attribute] -> [IDL.Member] -> [IDL.Member] -> NSM ([IDL.Member], [IDL.Defn]) simplifyMembers _ _ [] = return ([], []) simplifyMembers p_attrs mems ((ty, attrs, [IDL.FunId i cc ps]):ms) = do let ps' = removeVoidParam ps nm <- getNewName (ty', ds1) <- simplifyType True (IDLUtils.childAttributes (attrs ++ p_attrs)) ty let ty_nm = nm def = IDL.Typedef (IDL.TyFun cc ty' ps') attrs [IDL.Id ty_nm] (ms', ds2) <- simplifyMembers p_attrs mems ms return ((IDL.TyName ty_nm Nothing, attrs, [i]):ms', ds1++def:ds2) simplifyMembers p_attrs mems (m@(ty, attrs, is):ms) | isConstructedTy ty && any isUnpointedId is = do nm <- getNewName let {- In case we're lifting a (non-encap) union out of a struct, make sure we record the type of the switch. -} attrs' = case ty of IDL.TyUnionNon{} -> attrs ++ switch_ty_attr IDL.TyCUnion{} -> attrs ++ switch_ty_attr _ -> attrs switch_ty_attr | any isSwitchType (attrs ++ p_attrs) = [] | otherwise = case filter (isSwitchIs) (attrs ++ p_attrs) of (IDL.Attrib _ [l] : _) -> let n = fromMaybe "" (findName l) in case (filter (isField n) mems) of ((s_ty,_,_):_) -> [IDL.Attrib (IDL.Id "switch_type") [IDL.AttrLit (TypeConst (showIDL (PpIDL.ppType s_ty)))]] _ -> [] _ -> [] -- ToDo: lift out into utility module. findName (IDL.AttrExpr e) = findNameExpr e findName IDL.EmptyAttr = Nothing findName (IDL.AttrLit (TypeConst tc)) = Just tc findName (IDL.AttrPtr a) = findName a findNameExpr expr = case expr of IDL.Binary _ e1 e2 -> findNameExpr e1 `concMaybe` findNameExpr e2 IDL.Cond e1 e2 e3 -> findNameExpr e1 `concMaybe` findNameExpr e2 `concMaybe` findNameExpr e3 IDL.Unary _ e1 -> findNameExpr e1 IDL.Var v -> Just v IDL.Cast _ e -> findNameExpr e IDL.Sizeof _ -> Nothing IDL.Lit (TypeConst tc) -> Just tc IDL.Lit _ -> Nothing isSwitchIs (IDL.Attrib (IDL.Id "switch_is") _) = True isSwitchIs _ = False isSwitchType (IDL.Attrib (IDL.Id "switch_type") _) = True isSwitchType _ = False isField n (_,_,ss) = any isNm ss where isNm (IDL.Id inm) = inm == n isNm _ = False (ty', ds1) <- simplifyType True (attrs' ++ IDLUtils.childAttributes p_attrs) ty let def = IDL.Typedef ty' attrs [IDL.Id nm] (ms', ds2) <- simplifyMembers p_attrs mems ms return ((IDL.TyName nm Nothing, attrs', is):ms', ds1 ++ def:ds2) | otherwise = do (ms', ds) <- simplifyMembers p_attrs mems ms return (m:ms', ds) simplifySwitches :: [IDL.Switch] -> NSM ([IDL.Switch], [IDL.Defn]) simplifySwitches [] = return ([],[]) simplifySwitches ((IDL.Switch labs arm):ss) = do (arm', ds) <- simplifyArm arm (ss', ds') <- simplifySwitches ss return ((IDL.Switch labs arm'):ss', ds++ds') simplifyArm :: Maybe IDL.SwitchArm -> NSM (Maybe IDL.SwitchArm, [IDL.Defn]) simplifyArm Nothing = return (Nothing,[]) simplifyArm (Just (IDL.Param i ty attrs)) = do (ty',ds) <- simplifyType True attrs ty return (Just (IDL.Param i ty' attrs), ds) \end{code} @tidyDefns@ takes care of moving typedefs for constructed type references to the site where the constructed type is actually defined. Doing this is required to generate the right data type defns. for an example like the following: \begin{verbatim} typedef struct foo bar; typedef struct foo { bar *ptr; int i; } *pbar; \end{verbatim} The two typedefs are combined into one (earlier passes will have checked that "struct foo" is a valid structure reference.) Need to cope with both forward and backward references, so we make one pass over the decls trying to move forward references to their definition site, followed by another pass trying to reposition the backward type references. This pass isn't required if you're processing already normalised input, i.e., input coming from the TLB reader, so an option is provided for turning this 2-pass off. \begin{code} tidyDefns :: [IDL.Defn] -> [IDL.Defn] tidyDefns orig_ds | optTlb || optDon'tTidyDefns = orig_ds | otherwise = case (tidyDefns' True [] [] [] orig_ds) of ([], [], ds) -> ds (cands, removeds, ds') -> case (tidyDefns' False cands removeds [] ds') of {- We remove a definition from its original site only if we can successfully move it to a more appropriate site. Leftovers in the candidate list that by now haven't found a better home are simply dropped, and the defns therein are thereby left at their original site. -} (_,_,ds'') -> ds'' where {- Used by debugging code. defTag (IDL.TypeDecl t) = tyTag t defTag (IDL.Typedef t _ is) = tyTag t ++ showList (map iName is) "" defTag _ = "" removeDefs rs ds = filter (\x -> not (x `elem` rs)) ds -} removeDef d ds = filter (/=d) ds tidyDefns' _ cands removeds acc_ds [] = (cands, removeds, reverse acc_ds) tidyDefns' newFlag cands removeds acc_ds (d:ds) = case d of IDL.Typedef ty as is | isConstructedTy ty -- enum/struct/union && (isReferenceTy ty || -- "typedef enum foo bar;" any isMIDLishId is ) -- "typedef enum { ... } __MIDL__MIDL__.... ;" -> if newFlag then tidyDefns' newFlag (d:cands) removeds (d:acc_ds) ds else if d `elem` removeds then tidyDefns' newFlag cands removeds acc_ds ds else tidyDefns' newFlag cands removeds (d:acc_ds) ds | isConstructedTy ty && isCompleteTy ty && haveForwardRef (tyTag ty) cands -> let (new_cands, moved_to_new_home, d') = moveForwardRef d cands in tidyDefns' newFlag new_cands (d:removeds) -- (moved_to_new_home ++ removeds) (d': acc_ds) ds -- (d':removeDefs moved_to_new_home acc_ds) ds | isMIDLishTy ty && haveMIDLRef (tyTag ty) cands -> let (new_cands, d') = moveForwardMIDLRef d cands in tidyDefns' newFlag new_cands (d:removeds) (d':removeDef d acc_ds) ds IDL.TypeDecl ty | d `elem` removeds -> tidyDefns' newFlag cands removeds acc_ds ds | isConstructedTy ty && isCompleteTy ty && haveForwardRef (tyTag ty) cands -> let (new_cands, moved_to_new_home, d') = moveForwardRef d cands in tidyDefns' newFlag new_cands (d:removeds) --removeds --(d:moved_to_new_home ++ removeds) (d': acc_ds) ds --(d':removeDefs moved_to_new_home acc_ds) ds | isConstructedTy ty && haveForwardRef (tyTag ty) cands {- If we see "typedef struct _P p; struct _P", remove the second decl entirely. -} -> tidyDefns' newFlag cands removeds acc_ds ds IDL.Attributed a a_d -> let (new_cands,rs,d') = tidyDefns' newFlag cands removeds [] [a_d] attr_d = map (IDL.Attributed a) d' in tidyDefns' newFlag new_cands rs (attr_d ++ acc_ds) ds IDL.Interface i inh i_ds -> let i_ds' | newFlag = tidyDefns i_ds | otherwise = i_ds in tidyDefns' newFlag cands removeds ((IDL.Interface i inh i_ds'):acc_ds) ds IDL.Module i m_ds -> let m_ds' | newFlag = tidyDefns m_ds | otherwise = m_ds in tidyDefns' newFlag cands removeds ((IDL.Module i m_ds'):acc_ds) ds IDL.Library i l_ds -> let l_ds' | newFlag = tidyDefns l_ds | otherwise = l_ds in tidyDefns' newFlag cands removeds ((IDL.Library i l_ds'):acc_ds) ds IDL.DispInterface i a d_ds -> let d_ds' | newFlag = tidyDefns d_ds | otherwise = d_ds in tidyDefns' newFlag cands removeds ((IDL.DispInterface i a d_ds'):acc_ds) ds _ -> tidyDefns' newFlag cands removeds (d:acc_ds) ds haveForwardRef :: String -> [IDL.Defn] -> Bool haveForwardRef nm ls = go ls where go [] = False go ((IDL.Typedef t _ _):_) | tyTag t == nm = True go (_:ds) = go ds -- to avoid (harmless) duplication later on, tag the -- moved/introduced defn with an 'ignore' attribute. -- ==> no Haskell code will be generated for it. moveForwardRef :: IDL.Defn -> [IDL.Defn] -> ([IDL.Defn], [IDL.Defn], IDL.Defn) moveForwardRef (IDL.TypeDecl t) ls = (ls', cs, IDL.Typedef t (concat as) (concat is)) where nm = tyTag t (cs,ls') = partition (\ (IDL.Typedef ty _ _) -> tyTag ty == nm) ls (as,is) = unzip (map (\ (IDL.Typedef _ as1 is1) -> (as1,is1)) cs) moveForwardRef (IDL.Typedef t attrs is1) ls = (ls', cs, IDL.Typedef t (attrs++concat as) (is1++map addIgnoreAttrib (concat is))) where nm = tyTag t (cs,ls') = partition (\ (IDL.Typedef ty _ _) -> tyTag ty == nm) ls (as,is) = unzip (map (\ (IDL.Typedef _ as1 is2) -> (as1,is2)) cs) addIgnoreAttrib i = IDL.AttrId [IDL.Attrib (IDL.Id "ignore") []] i -- should never happen moveForwardRef d ls = trace "moveForwardRef: funny defn." (ls, [], d) haveMIDLRef :: String -> [IDL.Defn] -> Bool haveMIDLRef nm = any (\ (IDL.Typedef _ _ is) -> notNull (filter (midlLooking nm) is)) midlLooking :: String -> IDL.Id -> Bool midlLooking nm x = isMIDLishId x && nm == iName x moveForwardMIDLRef :: IDL.Defn -> [IDL.Defn] -> ([IDL.Defn], IDL.Defn) moveForwardMIDLRef (IDL.Typedef t attrs is) ls = case break isMIDLDefn ls of (as, (IDL.Typedef real_ty attrs1 _ :bs)) -> (as++bs, IDL.Typedef real_ty (attrs1 ++ attrs) is) where nm = tyTag t isMIDLDefn (IDL.Typedef _ _ t_is) = notNull (filter (midlLooking nm) t_is) isMIDLDefn _ = False -- should never happen moveForwardMIDLRef d ls = trace "moveForwardMIDLRef: funny defn." (ls, d) \end{code} Ad-hac hockily, we allow a different name to be assocaiated with an import name. \begin{code} nameOfImport :: String -> DsM String nameOfImport nm | not optUseAsfs = return nm | otherwise = do x <- lookupAsf nm case x of Just (_,as) -> do c_as <- mapM idlToCoreAttribute as case findAttribute "hs_name" c_as of Just (Core.Attribute _ [Core.ParamLit (StringLit s)]) -> return s _ -> return nm _ -> return nm \end{code}