% % Daan Leijen, 1997, leijen@fwi.uva.nl % Sigbjorn Finne, 1998-. % Com/OLE type library front-end. This code is COM dependent, so you'll have to explicitly compile it in (see Makefile). [sof 11/98 - rewritten, extended and integrated into H/Direct sources.] \begin{code} module ImportLib ( importLib ) where import IDLSyn {- BEGIN_NOT_SUPPORT_TYPELIBS -} importLib :: String -> IO Defn importLib nm = return (Pragma ("importLib: type library reader not compiled in. " ++ nm)) {- END_NOT_SUPPORT_TYPELIBS -} {- BEGIN_SUPPORT_TYPELIBS -- to the end of the file. import HDirect import Com hiding (GUID) import qualified Com ( GUID ) import ComPrim ( lOCALE_USER_DEFAULT ) import Automation hiding (GUID,DISPID, Member) import TypeLib import BasicTypes import Literal import Opts import IDLUtils hiding ( noAttrs ) import Utils ( notNull ) import Foreign.Ptr {- #ifdef DEBUG -} import PpIDLSyn ( showIDL, ppType ) {- #endif -} import System.IO import Word ( Word32 ) import Int import NumExts ( floatToDouble ) import IO import Bits import Monad ( when ) import List import Maybe ( catMaybes ) \end{code} %----------------------------------------------------------- %-- Read TypeLib %----------------------------------------------------------- \begin{code} importLib :: String -> IO Defn importLib libfile = do -- pretend you didn't see the next line.. writeIORef libs_seen_ref [] #ifdef DEBUG hPutStrLn stderr ("typelib: " ++ libfile) #endif unk <- (loadTypeLib libfile `catch` \ _ -> ioError (userError ("couldn't load: "++libfile))) typelib <- unk # queryInterface iidITypeLib (libName, docString, hContext, hString) <- typelib # getLibName #ifdef DEBUG hPutStrLn stderr ("typelib name: " ++ libName) #endif (hStringContext, hStringDll) <- catch ( do typelib2 <- typelib # queryInterface iidITypeLib2 (_,ctxt, dlln) <- typelib2 # getDocumentation2TL (-1) lOCALE_USER_DEFAULT return (ctxt, dlln)) ( \ _ -> return (0,"")) ~(Just libAttr) <- typelib # getLibAttr maxItem <- typelib # getTypeInfoCount #ifdef DEBUG hPutStrLn stderr ("typelib contains " ++ show maxItem ++ " items") #endif let indices | maxItem == 0 = [] | otherwise = [0 .. (fromIntegral maxItem)-1] customs <- typelib # getCustomTL libItems <- mapM (\ x -> typelib # readItem [libName] x) indices let lFlags = wLibFlags libAttr attrs = catMaybes [ versionAttr (wMajorVerNum0 libAttr) (wMinorVerNum0 libAttr) , Just $ uuidAttribute (guid1 libAttr) , helpStringAttr docString , helpContextAttr (toInteger hContext) , helpFileAttr hString , helpStringDllAttr hStringDll , helpStringCtxtAttr (toInteger hStringContext) , lcidvalAttribute (toInteger (lcid0 libAttr)) , isSet lFlags 0x1 restrictedAttribute , isSet lFlags 0x2 controlAttribute , isSet lFlags 0x4 hiddenAttribute ] ++ customs sorted_libItems = sortDefns libItems rpath <- catch (queryPathOfRegTypeLib (guid1 libAttr) (wMajorVerNum0 libAttr) (wMinorVerNum0 libAttr)) ( \ _ -> return "") ls <- readIORef libs_seen_ref let ls' = filter (/=rpath) ls imps = map ImportLib ls' return (Attributed attrs (Library (Id libName) (imps ++ sorted_libItems))) \end{code} \begin{code} readItem :: Level -> Int -> ITypeLib a -> IO Defn readItem level index typelib = do #ifdef DEBUG hPutStrLn stderr ("readItem: " ++ show index) #endif itemName <- typelib # getItemName (fromIntegral index) #ifdef DEBUG hPutStrLn stderr ("readItem:" ++ show itemName) #endif let level' = level ++ [itemName] when optDebug (hPutStrLn stderr (show level')) typeinfo <- typelib # getTypeInfo (fromIntegral index) -- make sure we're holding on to this (forever, basically.) -- The reason for doing this is that we're here unravelling stuff -- from the TI, including GUIDs (c.f., 'guid' field in the TYPEATTR) -- which we don't copy, but merely store a (finalised) pointer to. -- -- Even though we're not releasing the TYPEATTR, releasing the TI -- seems to release it for us. Uncool behaviour (where is *this* -- documented??), but not much we can do about it. So, increase -- the ref. count on the TI by one, so that we ensure it is held onto -- (until we eventually shut down.) -- -- ToDo: avoid these troubles by copying GUIDs and VARIANTs into -- freshly allocated memory...? -- typeinfo # addRef (Just typeAttr) <- typeinfo # getTypeAttr case (typekind typeAttr) of TKIND_ALIAS -> typeinfo # readAlias itemName level' typeAttr TKIND_ENUM -> typeinfo # readEnum itemName level' typeAttr TKIND_RECORD -> typeinfo # readRecord itemName level' True typeAttr TKIND_UNION -> typeinfo # readRecord itemName level' False typeAttr TKIND_INTERFACE -> typeinfo # readInterface itemName level' typeAttr TKIND_DISPATCH | isDual typeAttr -> typeinfo # readDual itemName level' | otherwise -> typeinfo # readDispatch itemName level' typeAttr TKIND_COCLASS -> typeinfo # readCoClass itemName level' typeAttr TKIND_MODULE -> typeinfo # readModule itemName level' typeAttr _ -> do hPutStrLn stderr "Something else" return (CppQuote "") -- To identify the context we're processing, pass down a list of names -- (v. useful when dumping out warnings.) type Level = [Name] \end{code} ----------------------------------------------------------- -- READ DISPATCH, we should do a lot more error checking -- here (SAFEARRAY, dispatch types etc.) ----------------------------------------------------------- \begin{code} readDispatch :: Name -> Level -> TYPEATTR -> ITypeInfo a -> IO Defn readDispatch name level typeAttr typeinfo = do #ifdef DEBUG hPutStrLn stderr ("readDispatch: " ++ show name) #endif methods <- mapM (\ x -> typeinfo # readDispMember level x) [0..((fromIntegral (cFuncs typeAttr))-1)] vars <- mapM (\ x -> typeinfo # readDispVar level x) [0..((fromIntegral (cVars typeAttr))-1)] (libName, docString, hContext, hString, hStringContext, hStringDll) <- typeinfo # getHelpAttributesTI (-1) customs <- typeinfo # getCustomTI let tFlags = wTypeFlags typeAttr real_methods = filter (not.isStdJunk) methods isStdJunk (Attributed _ (Operation (FunId (Id nm) _ _) _ _ _)) = nm `elem` std_meths isStdJunk _ = False -- we're less than interested in these. std_meths = ["QueryInterface", "AddRef", "Release", "GetTypeInfoCount", "GetTypeInfo", "GetIDsOfNames", "Invoke" ] disp_attrs = catMaybes [ Just $ uuidAttribute (guid typeAttr) , versionAttr (wMajorVerNum typeAttr) (wMinorVerNum typeAttr) , isSet tFlags 0x10 hiddenAttribute , helpStringAttr docString , helpContextAttr (toInteger hContext) , helpFileAttr hString , helpStringDllAttr hStringDll , helpStringCtxtAttr (toInteger hStringContext) ] ++ customs return (Attributed disp_attrs (DispInterface (Id name) vars real_methods)) readDispMember :: Level -> Int -> ITypeInfo a -> IO Defn readDispMember level' index typeinfo = do #ifdef DEBUG hPutStrLn stderr ("readDispMember: " ++ show level') #endif ~(Just funcDesc) <- typeinfo # getFuncDesc (fromIntegral index) metName <- typeinfo # getMemberName (memid funcDesc) customs <- typeinfo # getCustomTI (libName, docString, hContext, hString, hStringContext, hStringDll) <- typeinfo # getHelpAttributesTI (fromIntegral (memid funcDesc)) let fFlags = wFuncFlags funcDesc mId = memid funcDesc mId' = toInteger (int32ToWord32 mId) iKind = invkind funcDesc disp_attrs = (case iKind of INVOKE_FUNC -> id INVOKE_PROPERTYGET -> ((Attrib (Id "propget") []):) INVOKE_PROPERTYPUT -> ((Attrib (Id "propput") []):) INVOKE_PROPERTYPUTREF -> ((Attrib (Id "propputref") []):)) $ catMaybes [ Just $ Attrib (Id "id") [AttrLit (IntegerLit (ILit 16 mId'))] , isSet fFlags 0x4 (Attrib (Id "bindable") []) , isSet fFlags 0x20 (Attrib (Id "defaultbind") []) , isSet fFlags 0x100 (Attrib (Id "defaultcollelem") []) , isSet fFlags 0x10 (Attrib (Id "displaybind") []) , isSet fFlags 0x40 hiddenAttribute , isSet fFlags 0x1000 (Attrib (Id "immediatebind") []) , isSet fFlags 0x400 (Attrib (Id "nonbrowsable") []) , isSet fFlags 0x800 (Attrib (Id "replaceable") []) , isSet fFlags 0x8 (Attrib (Id "requestedit") []) , isSet fFlags 0x1 (Attrib (Id "restricted") []) , isSet fFlags 0x2 (Attrib (Id "source") []) , isSet fFlags 0x200 (Attrib (Id "uidefault") []) , helpStringAttr docString , helpContextAttr (toInteger hContext) , helpFileAttr hString , helpStringDllAttr hStringDll , helpStringCtxtAttr (toInteger hStringContext) -- , Just (Attrib (Id "offset") [AttrLit (IntegerLit (ILit 10 (toInteger (memid funcDesc))))]) ] ++ customs level = level' ++ [metName] is_dispatch <- checkKind level (funckind funcDesc) (params,metType) <- readMethodType iKind level funcDesc typeinfo let cc = Just (toCallConv (callconv funcDesc)) let (res_ty, fun_id) = case metType of TyPointer t -> (t, FunId (Pointed [[]] (Id metName)) cc params) _ -> (metType, FunId (Id metName) cc params) return (Attributed disp_attrs (Operation fun_id res_ty Nothing Nothing)) where checkKind level kind = case kind of FUNC_DISPATCH -> return True _ -> do giveWarning level ["cannot translate non-dispatch functions (you used the '-auto' flag)"] return False readDispVar :: Level -> Int -> ITypeInfo a -> IO ([Attribute], Type, Id) --Defn readDispVar level index typeinfo = do #ifdef DEBUG hPutStrLn stderr ("readDispVar: " ++ show level) #endif ~(Just varDesc) <- typeinfo # getVarDesc (fromIntegral index) metName <- typeinfo # getMemberName (memid0 varDesc) customs <- typeinfo # getCustomTI (libName, docString, hContext, hString, hStringContext, hStringDll) <- typeinfo # getHelpAttributesTI (fromIntegral (memid0 varDesc)) propType <- typeinfo # readElemType (level++[metName]) (elemdescVar varDesc) propOffset <- case (iHC_TAG_7 varDesc) of OInst x -> return x _ -> error "ImportLib.readDispVar: VARDESC is non-ideal" let vFlags = wVarFlags varDesc mId = memid0 varDesc mId' = toInteger (int32ToWord32 mId) prop_attrs = catMaybes [ Just $ Attrib (Id "id") [AttrLit (IntegerLit (ILit 16 mId'))] , isSet vFlags 0x1 (Attrib (Id "readonly") []) , isSet vFlags 0x2 (Attrib (Id "source") []) , isSet vFlags 0x4 (Attrib (Id "bindable") []) , isSet vFlags 0x8 (Attrib (Id "requestedit") []) , isSet vFlags 0x10 (Attrib (Id "displaybind") []) , isSet vFlags 0x20 (Attrib (Id "defaultbind") []) , isSet vFlags 0x40 hiddenAttribute , isSet vFlags 0x80 (Attrib (Id "restricted") []) , isSet vFlags 0x100 (Attrib (Id "defaultcollelem") []) , isSet vFlags 0x200 (Attrib (Id "uidefault") []) , isSet vFlags 0x400 (Attrib (Id "nonbrowsable") []) , isSet vFlags 0x800 (Attrib (Id "replaceable") []) , isSet vFlags 0x1000 (Attrib (Id "immediatebind") []) , helpStringAttr docString , helpContextAttr (toInteger hContext) , helpFileAttr hString , helpStringDllAttr hStringDll , helpStringCtxtAttr (toInteger hStringContext) ] ++ customs -- propId = mkId metName metName prop_attrs return (prop_attrs, propType, Id metName) \end{code} ----------------------------------------------------------- -- ALIAS ----------------------------------------------------------- \begin{code} readAlias :: Name -> Level -> TYPEATTR -> ITypeInfo a -> IO Defn readAlias i_name level typeAttr typeinfo = do #ifdef DEBUG hPutStrLn stderr ("readAlias: " ++ show i_name) #endif alias <- typeinfo # readType level (tdescAlias typeAttr) (libName, docString, hContext, hString, hStringContext, hStringDll) <- typeinfo # getHelpAttributesTI (-1) let tFlags = wTypeFlags typeAttr gd = guid typeAttr the_uuid_attr | gd == nullGUID = Nothing | otherwise = Just (uuidAttribute gd) alias_attrs = catMaybes [ Just $ Attrib (Id "public") [] , the_uuid_attr , helpStringAttr docString , helpContextAttr (toInteger hContext) , helpFileAttr hString , helpStringDllAttr hStringDll , helpStringCtxtAttr (toInteger hStringContext) , isSet tFlags 0x10 hiddenAttribute , isSet tFlags 0x200 restrictedAttribute ] -- the desugarer likes to see the Id as pointed if -- the type is, so we'll oblige. case alias of -- TyPointer t@(TyIface _) -> return (Typedef t alias_attrs [Id i_name]) TyPointer t -> return (Typedef t alias_attrs [Pointed [[]] (Id i_name)]) _ -> return (Typedef alias alias_attrs [Id i_name]) \end{code} ----------------------------------------------------------- -- ENUM ----------------------------------------------------------- \begin{code} readEnum :: Name -> Level -> TYPEATTR -> ITypeInfo a -> IO Defn readEnum e_name level typeAttr typeinfo = do values <- mapM ((typeinfo # ).readEnumValue level) [0..((fromIntegral (cVars typeAttr))-1)] -- bizarrely, some enumerations were either not defined in let s_values = sortBy cmp values cmp (_,_, Just (Lit (IntegerLit (ILit _ x)))) (_,_, Just (Lit (IntegerLit (ILit _ y)))) = compare x y return (Typedef (TyEnum (Just (Id e_name)) s_values) [] [Id e_name]) readEnumValue :: Level -> Int -> ITypeInfo a -> IO (Id, [Attribute], Maybe Expr) readEnumValue level index typeinfo = do #ifdef DEBUG hPutStrLn stderr ("readEnumValue: " ++ show level) #endif (Just varDesc) <- typeinfo # getVarDesc (fromIntegral index) enumName <- typeinfo # getMemberName (memid0 varDesc) #ifdef DEBUG hPutStrLn stderr ("readEnumValue: " ++ show enumName) #endif (libName, docString, hContext, hString, hStringContext, hStringDll) <- typeinfo # getHelpAttributesTI (fromIntegral (memid0 varDesc)) enumValue <- case (varkind varDesc) of VAR_CONST -> do case (iHC_TAG_7 varDesc) of LpvarValue (Just var) -> do vt <- readVarEnum var case vt of VT_I2 -> readVarInt (castPtr var) VT_I4 -> readVarInt (castPtr var) _ -> do giveWarning level ["Expecting integer intializer for enumeration", "assume: " ++ show index] return (fromIntegral index) _ -> do giveWarning level [ "ImportLib.readEnumValue: unpack unionVARDESC is bogus." , "Assuming " ++ show index ++ " instead." ] return (fromIntegral index) _ -> do giveWarning (level++[enumName]) ["enumeration tag / constant is not constant!", "assume: " ++ show index] return (fromIntegral index) let attrs = catMaybes [ helpStringAttr docString , helpContextAttr (toInteger hContext) , helpFileAttr hString , helpStringDllAttr hStringDll , helpStringCtxtAttr (toInteger hStringContext) ] return (Id enumName, attrs, Just (Lit (iLit enumValue))) -- ToDo: merge with the above VAR_CONST de-pickling code. readConst :: Level -> Int -> ITypeInfo a -> IO Defn readConst level index typeinfo = do (Just varDesc) <- typeinfo # getVarDesc (fromIntegral index) cName <- typeinfo # getMemberName (memid0 varDesc) #ifdef DEBUG hPutStrLn stderr ("readConst: " ++ cName) #endif (libName, docString, hContext, hString, hStringContext, hStringDll) <- typeinfo # getHelpAttributesTI (-1) customs <- typeinfo # getCustomTI (ty,val) <- case (varkind varDesc) of VAR_CONST -> do case (iHC_TAG_7 varDesc) of LpvarValue (Just var) -> do vt <- readVarEnum var case vt of VT_I1 -> do v <- readVarInt (castPtr var) return (TyApply (TySigned True) TyChar, Lit (iLit v)) VT_I2 -> do v <- readVarInt (castPtr var) return (tyInt16, Lit (iLit v)) VT_I4 -> do v <- readVarInt (castPtr var) return (tyInt32, Lit (iLit v)) VT_UI1 -> do v <- readVarInt (castPtr var) return (tyWord16, Lit (iLit v)) VT_UI2 -> do v <- readVarInt (castPtr var) return (tyWord16, Lit (iLit v)) VT_UI4 -> do v <- readVarInt (castPtr var) return (tyWord32, Lit (iLit v)) VT_LPSTR -> do (pbstr,_) <- readVarString (castPtr var) str <- readBSTR (castPtr pbstr) return (tyString, Lit (StringLit str)) VT_BSTR -> do (pbstr,_) <- readVarString (castPtr var) str <- readBSTR (castPtr pbstr) return (tyString, Lit (StringLit str)) VT_LPWSTR -> do (pbstr,_) <- readVarString (castPtr var) str <- readBSTR (castPtr pbstr) return (tyString, Lit (StringLit str)) -- ToDo: fix. VT_BOOL -> do v <- readVarBool var return (tyVariantBool, Lit (BooleanLit v)) _ -> do giveWarning level ["Expecting integer intializer for enumeration (found: " ++ show (fromEnum vt) ++ ")", "assume : " ++ show index] return (tyInt32, Lit (iLit index)) _ -> do giveWarning level [ "ImportLib.readConst: unpack unionVARDESC is 'odd'." , "Assuming " ++ show index ++ " (signed long) instead." ] -- Anything to avoid stopping (the user can patch up the output -- instead!) return (tyInt32, Lit (iLit index)) _ -> do giveWarning (level++[cName]) ["constant is not constant!", "assume: " ++ show index, " (signed long)"] return (tyInt32, Lit (iLit index)) let vFlags = wVarFlags varDesc -- most of these don't apply, but what the h... attrs = catMaybes [ isSet vFlags 0x1 (Attrib (Id "readonly") []) , isSet vFlags 0x2 (Attrib (Id "source") []) , isSet vFlags 0x4 (Attrib (Id "bindable") []) , isSet vFlags 0x8 (Attrib (Id "requestedit") []) , isSet vFlags 0x10 (Attrib (Id "displaybind") []) , isSet vFlags 0x20 (Attrib (Id "defaultbind") []) , isSet vFlags 0x40 hiddenAttribute , isSet vFlags 0x80 (Attrib (Id "restricted") []) , isSet vFlags 0x100 (Attrib (Id "defaultcollelem") []) , isSet vFlags 0x200 (Attrib (Id "uidefault") []) , isSet vFlags 0x400 (Attrib (Id "nonbrowsable") []) , isSet vFlags 0x800 (Attrib (Id "replaceable") []) , isSet vFlags 0x1000 (Attrib (Id "immediatebind") []) , helpStringAttr docString , helpContextAttr (toInteger hContext) , helpFileAttr hString , helpStringDllAttr hStringDll , helpStringCtxtAttr (toInteger hStringContext) ] ++ customs return (Constant (Id cName) attrs ty val) \end{code} ----------------------------------------------------------- -- RECORD ----------------------------------------------------------- \begin{code} readRecord :: Name -> Level -> Bool -> TYPEATTR -> ITypeInfo a -> IO Defn readRecord name level is_struct typeAttr typeinfo = do fields <- mapM ((typeinfo # ).readMember level) [0..((fromIntegral (cVars typeAttr)) -1)] let uuid = guid typeAttr attrs | uuid == nullGUID = [] | otherwise = [uuidAttribute uuid] --Attrib (Id "sz") [AttrLit (IntegerLit (ILit 10 (toInteger sz)))] -- sz = cbSizeInstance typeAttr tycon | is_struct = TyStruct | otherwise = TyCUnion ty = tycon (Just (Id name)) fields Nothing ret_un_ty = do when (not is_struct) (giveWarning level ["unions are only partially supported." ,"if this is an output parameter or a field member," ,"make sure to supply the right tag-reader."]) return (Typedef ty attrs [Id name]) {- This special case evaluates remoting unions to pick the inproc case. Horrible, but quite convenient. -} case fields of ((_,_,[Id "hInproc"]):(_,_, [Id "hRemote"]):_) | not is_struct -> return (Typedef (TyInteger Long) attrs [Id name]) _ | name == "_RemotableHandle" -> return (Typedef (TyInteger Long) attrs [Id name]) | otherwise -> ret_un_ty readMember :: Level -> Int -> ITypeInfo a -> IO Member readMember level index typeinfo = do #ifdef DEBUG hPutStrLn stderr ("readMember: " ++ show level) #endif (Just varDesc) <- typeinfo # getVarDesc (fromIntegral index) memName <- typeinfo # getMemberName (memid0 varDesc) #ifdef DEBUG hPutStrLn stderr ("readMember: " ++ show memName) #endif memType <- typeinfo # readElemType (level++[memName]) (elemdescVar varDesc) memOffset <- case (iHC_TAG_7 varDesc) of OInst x -> return x _ -> error "ImportLib.readMember: VARDESC has non-ideal shape" let attrs = [] --Attrib (Id "offset") [AttrLit (IntegerLit (ILit 10 (toInteger memOffset)))]] return (memType, attrs, [Id memName]) \end{code} ----------------------------------------------------------- -- COCLASS ----------------------------------------------------------- \begin{code} readCoClass :: Name -> Level -> TYPEATTR -> ITypeInfo a -> IO Defn readCoClass name level typeAttr typeinfo = do #ifdef DEBUG hPutStrLn stderr ("readCoClass: " ++ show name) #endif (libName, docString, hContext, hString, hStringContext, hStringDll) <- typeinfo # getHelpAttributesTI (-1) customs <- typeinfo # getCustomTI let tFlags = wTypeFlags typeAttr ifaces :: [Int] ifaces = [0..(fromIntegral (cImplTypes typeAttr))-1] attrs = catMaybes [ Just (uuidAttribute (guid typeAttr)) , versionAttr (wMajorVerNum typeAttr) (wMinorVerNum typeAttr) , isSet tFlags 1 (Attrib (Id "appobject") []) , isSet tFlags 1024 (Attrib (Id "aggregatable") []) , isSet tFlags 32 controlAttribute , isSet tFlags 16 hiddenAttribute , isSet tFlags 4 (Attrib (Id "licensed") []) , isn'tSet tFlags 2 (Attrib (Id "noncreatable") []) , helpStringAttr docString , helpContextAttr (toInteger hContext) , helpFileAttr hString , helpStringDllAttr hStringDll , helpStringCtxtAttr (toInteger hStringContext) ] ++ customs getOne n = catch ( do href <- typeinfo # getRefTypeOfImplType (fromIntegral n) tp <- typeinfo # getRefTypeInfo href (tpl,nIndex) <- tp # getContainingTypeLib tk <- tpl # getTypeInfoType nIndex v <- typeinfo # getImplTypeFlags (fromIntegral n) ~(Just tA) <- tp # getTypeAttr nm <- tp # getMemberName (-1) let i_attrs = catMaybes [ isSet v 1 (Attrib (Id "default") []) , isSet v 2 (Attrib (Id "source") []) , isSet v 4 restrictedAttribute , isSet v 0x800 (Attrib (Id "defaultvtable") []) ] kind = case tk of TKIND_DISPATCH | not (dualBitSet (wTypeFlags tA)) -> False _ -> True return (Just (kind, Id nm, i_attrs))) (\ _ -> do giveWarning level ["trouble reading coclass item " ++ show n ++ ", ignoring."] return Nothing) mems_mb <- mapM getOne ifaces let mems = catMaybes mems_mb return (Attributed attrs $ CoClass (Id name) mems) \end{code} \begin{code} readModule :: Name -> Level -> TYPEATTR -> ITypeInfo a -> IO Defn readModule name level typeAttr typeinfo = do methods <- mapM (\ x -> typeinfo # readMethod level x True) [0..(fromIntegral (cFuncs typeAttr) - 1)] (libName, docString, hContext, hString, hStringContext, hStringDll) <- typeinfo # getHelpAttributesTI (-1) customs <- typeinfo # getCustomTI flg <- (typeinfo # getImplTypeFlags (-1)) `catch` \ _ -> return 0 consts <- mapM ((typeinfo # ).readConst level) [0..((fromIntegral (cVars typeAttr))-1)] let getDllName [] = return "" getDllName (x:xs) = catch (do { (a,b,c) <- typeinfo # getDllEntry 0x60000000 x ; return a }) (\ _ -> getDllName xs) invs = [ INVOKE_FUNC , INVOKE_PROPERTYGET , INVOKE_PROPERTYPUT , INVOKE_PROPERTYPUTREF ] dll_name <- getDllName invs let tFlags = wTypeFlags typeAttr module_attrs = (catMaybes $ [ Just $ Attrib (Id "dllname") [AttrLit (StringLit dll_name)] , Just $ uuidAttribute (guid typeAttr) , helpStringAttr docString , helpContextAttr (toInteger hContext) , helpFileAttr hString , helpStringDllAttr hStringDll , helpStringCtxtAttr (toInteger hStringContext) , isSet tFlags 16 hiddenAttribute ]) ++ customs return (Attributed module_attrs $ Module (Id name) (concat methods ++ consts)) \end{code} ----------------------------------------------------------- -- DISPATCH-DUAL ----------------------------------------------------------- \begin{code} readDual :: Name -> Level -> ITypeInfo a -> IO Defn readDual name level typeinfo = do #ifdef DEBUG hPutStrLn stderr ("readDual: " ++ show name) #endif -- aargh, now we know why functional programming matters ! href <- typeinfo # getRefTypeOfImplType (-1) typeinfoIface <- typeinfo # getRefTypeInfo href (Just typeAttrIface) <- typeinfoIface # getTypeAttr typeinfoIface # readInterface name level typeAttrIface \end{code} ----------------------------------------------------------- -- INTERFACE ----------------------------------------------------------- \begin{code} readInterface :: Name -> Level -> TYPEATTR -> ITypeInfo a -> IO Defn readInterface name level typeAttr typeinfo = do #ifdef DEBUG hPutStrLn stderr ("readInterface: " ++ show name) #endif (libName, docString, hContext, hString, hStringContext, hStringDll) <- typeinfo # getHelpAttributesTI (-1) methods <- mapM (\ x -> typeinfo # readMethod level x False) [0..(fromIntegral (cFuncs typeAttr) - 1)] -- figure out who it inherits from. iherit <- (do hr <- typeinfo # getRefTypeOfImplType 0 itypeinfo <- typeinfo # getRefTypeInfo hr nm <- itypeinfo # getMemberName (-1) (typelib,_) <- itypeinfo # getContainingTypeLib ~(Just libAttr) <- typelib # getLibAttr rpath <- catch (queryPathOfRegTypeLib (guid1 libAttr) (wMajorVerNum0 libAttr) (wMinorVerNum0 libAttr)) (\ _ -> return "") when (notNull rpath) $ do rs <- readIORef libs_seen_ref case rpath `elem` rs of False -> writeIORef libs_seen_ref (rpath:rs) True -> return () return nm ) `catch` \ _ -> return "IUnknown" customs <- typeinfo # getCustomTI let tFlags = wTypeFlags typeAttr meth_attr = catMaybes [ Just (Attrib (Id "odl") []) , Just (uuidAttribute (guid typeAttr)) , isSet tFlags 0x40 (Attrib (Id "dual") []) , isSet tFlags 0x10 hiddenAttribute , isSet tFlags 0x80 (Attrib (Id "nonextensible") []) , isSet tFlags 0x100 (Attrib (Id "oleautomation") []) , isSet tFlags 0x200 restrictedAttribute , helpStringAttr docString , helpContextAttr (toInteger hContext) , helpFileAttr hString , helpStringDllAttr hStringDll , helpStringCtxtAttr (toInteger hStringContext) ] ++ customs return (Attributed meth_attr $ Interface (Id name) [iherit] (concat methods)) \end{code} ----------------------------------------------------------- -- METHOD ----------------------------------------------------------- \begin{code} readMethod :: Level -> Int -> Bool -> ITypeInfo a -> IO [Defn] -- methods. readMethod level' index in_module typeinfo = do #ifdef DEBUG hPutStrLn stderr ("readMethod: " ++ show level') #endif ~(Just funcDesc) <- typeinfo # getFuncDesc (fromIntegral index) r@(libName, docString, hContext, hString, hStringContext, hStringDll) <- typeinfo # getHelpAttributesTI (fromIntegral (memid funcDesc)) #ifdef DEBUG hPutStrLn stderr ("readMethod3: " ++ show docString) #endif metName <- typeinfo # getMemberName (memid funcDesc) #ifdef DEBUG hPutStrLn stderr ("readMethod4: " ++ show metName) #endif -- ~(Just varDesc) <- typeinfo # getVarDesc (fromIntegral index) customs <- typeinfo # getCustomTI let fId = memid funcDesc fId' = toInteger (int32ToWord32 fId) iKind = invkind funcDesc cons_entry <- if not in_module then return id else do (dname, nm, ord) <- typeinfo # getDllEntry fId iKind let dllname = Attrib (Id "dllname") [AttrLit (StringLit dname)] entry_a v = Attrib (Id "entry") [AttrLit v] case nm of "" -> return (\ x -> dllname : entry_a (IntegerLit (ILit 10 (toInteger ord))) : x) _ -> return (\ x -> dllname : entry_a (StringLit nm) : x) let level = level' ++ [metName] fFlags = wFuncFlags funcDesc id_nm = "id" metAttrs = cons_entry $ ((Attrib (Id id_nm) [AttrLit (IntegerLit (ILit 16 fId'))]):) $ (case iKind of INVOKE_FUNC -> id INVOKE_PROPERTYGET -> ((Attrib (Id "propget") []):) INVOKE_PROPERTYPUT -> ((Attrib (Id "propput") []):) INVOKE_PROPERTYPUTREF -> ((Attrib (Id "propputref") []):)) $ catMaybes [ isSet fFlags 0x100 (Attrib (Id "defaultcollelem") []) , isSet fFlags 0x40 hiddenAttribute , isSet fFlags 0x800 (Attrib (Id "replaceable") []) , isSet fFlags 0x2 (Attrib (Id "source") []) , isSet fFlags 0x200 (Attrib (Id "uidefault") []) , isSet fFlags 0x1 (Attrib (Id "restricted") []) , helpStringAttr docString , helpContextAttr (toInteger hContext) , helpFileAttr hString , helpStringDllAttr hStringDll , helpStringCtxtAttr (toInteger hStringContext) -- , Just $ Attrib (Id "offset") [AttrLit (IntegerLit (ILit 10 (toInteger (oVft funcDesc))))] ] ++ customs ok <- checkKind level (funckind funcDesc) if (not ok) then return [] else do (params, metType) <- typeinfo # readMethodType iKind level funcDesc let cc = Just (toCallConv (callconv funcDesc)) (res_ty, fun_id) = case metType of TyPointer t -> (t, FunId (Pointed [[]] (Id metName)) cc params) _ -> (metType, FunId (Id metName) cc params) return [Attributed metAttrs (Operation fun_id res_ty Nothing Nothing)] where checkKind level kind = case kind of FUNC_NONVIRTUAL -> do giveWarning level ["cannot translate non-virtual functions"] return False -- The rest can be handled, but let's just spell it out what -- kinds they are.. FUNC_VIRTUAL -> return True FUNC_PUREVIRTUAL -> return True FUNC_STATIC -> return True -- Legal inside module decls FUNC_DISPATCH -> return True toCallConv :: CALLCONV -> CallConv toCallConv cv = case cv of CC_CDECL -> Cdecl CC_MPWCDECL -> Cdecl CC_MSCPASCAL -> Pascal CC_PASCAL -> Pascal CC_MACPASCAL -> Pascal CC_MPWPASCAL -> Pascal CC_SYSCALL -> Stdcall _ -> Stdcall readMethodType :: INVOKEKIND -> [String] -> FUNCDESC -> ITypeInfo a -> IO ([Param], Type) readMethodType iKind level funcDesc typeinfo = do #ifdef DEBUG hPutStrLn stderr ("readMethodType: " ++ show level) #endif metType <- typeinfo # readElemType level (elemdescFunc funcDesc) #ifdef DEBUG hPutStrLn stderr ("readMethodType2: " ++ show (showIDL (ppType metType))) #endif let no_params = fromIntegral $ length (lprgelemdescParam funcDesc) + 1 parnames' <- typeinfo # getNames (memid funcDesc) no_params #ifdef DEBUG hPutStrLn stderr ("readMethodType3: " ++ show parnames') #endif let parnames = (tail parnames') ++ map tempname [(0::Int)..] tempname i = ("x" ++ show i) parlevels = map (\name -> level++[name]) parnames params <- mapM (\(l,name,elem) -> typeinfo # readParam iKind name l elem) (zip3 parlevels parnames (lprgelemdescParam funcDesc)) return (params, metType) readParam :: INVOKEKIND -> Name -> Level -> ELEMDESC -> ITypeInfo a -> IO Param readParam iKind name level elemDesc typeinfo = do partp <- typeinfo # readElemType level elemDesc customs <- typeinfo # getCustomTI let pdesc = paramdesc elemDesc pFlags = wParamFlags pdesc inout = pARAMFLAG_FIN .|. pARAMFLAG_FOUT parMode | pFlags .&. inout == inout = InOut | pFlags .&. pARAMFLAG_FIN == pARAMFLAG_FIN = In | pFlags .&. pARAMFLAG_FOUT == pARAMFLAG_FOUT = Out | otherwise = (\ x -> unsafePerformIO $ do when (optDebug) (giveWarning level ["non-moded parameter seen, " ++ name ++", assuming [" ++ show x ++ "]"]) return x) $ {- A little bit of (hard won) AI.. -} case iKind of INVOKE_PROPERTYGET | isPointed -> Out _ | isRetVal -> Out | otherwise -> In isPointed = case partp of TyPointer _ -> True TyArray _ _ -> True TyIface _ -> True _ -> False isRetVal = pFlags .&. pARAMFLAG_FRETVAL == pARAMFLAG_FRETVAL defVal <- case pparamdescex pdesc of Nothing -> return Nothing Just pd -> do let var = varDefaultValue pd vt <- readVarEnum var case vt of VT_I1 -> do v <- readVarInt var return (Just (iLit v)) VT_BOOL -> do v <- readVarBool var return (Just (BooleanLit v)) VT_I2 -> do v <- readVarInt var return (Just (iLit v)) VT_I4 -> do v <- readVarInt var return (Just (iLit v)) VT_UI1 -> do v <- readVarInt var return (Just (iLit v)) VT_UI2 -> do v <- readVarInt var return (Just (iLit v)) VT_UI4 -> do v <- readVarInt var return (Just (iLit v)) VT_R4 -> do v <- readVarFloat var return (Just (FloatingLit (show v, floatToDouble v))) VT_R8 -> do v <- readVarDouble var return (Just (FloatingLit (show v,v))) VT_LPSTR -> do (pbstr,_) <- readVarString var str <- readBSTR (castPtr pbstr) return (Just (StringLit str)) VT_BSTR -> do (pbstr,_) <- readVarString var str <- readBSTR (castPtr pbstr) return (Just (StringLit str)) VT_LPWSTR -> do (pbstr,_) <- readVarString var str <- readBSTR (castPtr pbstr) return (Just (StringLit str)) -- ToDo: fix. _ -> catch (do (pbstr,_) <- readVarString var str <- readBSTR (castPtr pbstr) return (Just (StringLit str))) (\ _ -> return Nothing) let par_attrs = catMaybes [ Just $ Mode parMode , isSet pFlags pARAMFLAG_FRETVAL retValAttribute , isSet pFlags pARAMFLAG_FOPT optionalAttribute , isSetMb pFlags pARAMFLAG_FHASDEFAULT (defaultAttribute defVal) , isSet pFlags pARAMFLAG_FLCID lcidAttribute ] ++ customs parType = partp {- case parType of TyIface typeName | not (typeName `elem` ["IUnknown", "IDispatch"]) -> do giveWarning level ["abstract interface seen",typeName] return () _ -> return () -} let par = Param (Id name) parType par_attrs return par \end{code} %----------------------------------------------------------- %-- Types %----------------------------------------------------------- \begin{code} readElemType :: Level -> ELEMDESC -> ITypeInfo a -> IO Type readElemType level elemDesc typeinfo = typeinfo # readType level (tdesc elemDesc) readType :: Level -> TYPEDESC -> ITypeInfo a -> IO Type readType level typeDesc typeinfo = do #ifdef DEBUG hPutStrLn stderr ("readType: " ++ show level) #endif -- recordExternalTlbDependency typeinfo index case (toEnum (fromIntegral (vt typeDesc))) of VT_I2 -> return tyShort VT_I4 -> return tyInt VT_R4 -> return tyFloat VT_R8 -> return tyDouble VT_LPSTR -> return tyString VT_LPWSTR -> return tyWString VT_BSTR -> return tyBSTR VT_ERROR -> return tyHRESULT VT_HRESULT -> return tyHRESULT VT_UNKNOWN -> return (TyPointer tyIUnknown) VT_BOOL -> return tyVariantBool VT_I1 -> return tyChar VT_UI1 -> return tyByte VT_UI2 -> return tyWord16 VT_UI4 -> return tyWord32 VT_I8 -> return tyInt64 VT_UI8 -> return tyWord64 VT_INT -> return tyInt32 VT_UINT -> return tyWord32 VT_VOID -> return tyVoid VT_PTR -> do tp <- case (iHC_TAG_1 typeDesc) of Lptdesc (Just td) -> typeinfo # readType level td Lpadesc _ -> ioError (userError "ImportLib.readType: arraydesc, what to do?") Hreftype href -> typeinfo # trackType level href _ -> ioError (userError "ImportLib.readType: anon - que pasa?") case tp of TyArray t [] -> return (TyPointer t) -- Don't like this. _ -> return (TyPointer tp) VT_CARRAY -> do case (iHC_TAG_1 typeDesc) of Lpadesc (Just ad) -> do elemType <- typeinfo # readType level (tdescElem ad) let bounds = rgbounds ad exprs = map (Lit . iLit . cElements) bounds case elemType of TyChar | length exprs == 1 -> return (TyPointer TyChar) -- hack (but a convenient one!) :) _ -> return (TyArray elemType exprs) Lpadesc _ -> ioError (userError "ImportLib.readType{carray}: arraydesc, what to do?") Hreftype href -> typeinfo # trackType level href _ -> ioError (userError "ImportLib.readType{carray}: anon - que pasa?") VT_USERDEFINED -> case (iHC_TAG_1 typeDesc) of Hreftype href -> typeinfo # trackType level href _ -> ioError (userError "ImportLib.readType{userdefined}: unpack unionTYPEDESC.hreftype error") VT_CLSID -> return tyGUID VT_DISPATCH -> return (TyPointer tyIDispatch) VT_VARIANT -> return tyVARIANT VT_SAFEARRAY -> case (iHC_TAG_1 typeDesc) of Lpadesc (Just ad) -> do elemType <- typeinfo # readType level (tdescElem ad) return (tySafeArray elemType) Lptdesc (Just td) -> do elemType <- typeinfo # readType level td return (tySafeArray elemType) Hreftype href -> typeinfo # trackType level href _ -> ioError (userError "ImportLib.readType{sarray}: unpack unionTYPEDESC.lpadesc error") VT_CY -> return tyCURRENCY VT_DATE -> return tyDATE VT_FILETIME -> return tyFILETIME VT_BLOB -> return tyAddr VT_STREAM -> return tyIStream VT_STORAGE -> return tyIStorage VT_NULL -> errtype "null" VT_EMPTY -> errtype "empty" VT_STREAMED_OBJECT -> errtype "streamed object" VT_STORED_OBJECT -> errtype "stored object" VT_BLOB_OBJECT -> errtype "BLOB object" _ -> errtype "Unknown" where errtype msg = do giveWarning level ["unknown type: "++ show msg ++", interpreting it as void*"] return (TyPointer TyVoid) trackType :: Level -> HREFTYPE -> ITypeInfo a -> IO Type trackType level href typeinfo = catch (do typeinfoRef <- typeinfo # getRefTypeInfo href (typelib,index) <- typeinfoRef # getContainingTypeLib ~(Just libAttr) <- typelib # getLibAttr rpath <- catch (queryPathOfRegTypeLib (guid1 libAttr) (wMajorVerNum0 libAttr) (wMinorVerNum0 libAttr)) (\ _ -> return "") when (notNull rpath) $ do rs <- readIORef libs_seen_ref case rpath `elem` rs of False -> writeIORef libs_seen_ref (rpath:rs) True -> return () (Just typeAttr) <- typeinfoRef # getTypeAttr case (typekind typeAttr) of TKIND_ENUM -> do ename <- typelib # typeNamed (fromIntegral index) return (TyName ename Nothing) TKIND_RECORD -> do sname <- typelib # typeNamed (fromIntegral index) return (TyName sname Nothing) TKIND_UNION -> do uname <- typelib # typeNamed (fromIntegral index) fields <- mapM ((typeinfoRef # ).readMember level) [0..((fromIntegral (cVars typeAttr)) -1)] let {- This special case evaluates remoting unions to pick the inproc case. Horrible, but quite convenient. -} ret_un_ty = do giveWarning level ["unions are only partially supported.", "if this is an output parameter or a field member,", "make sure to supply the right tag-reader."] return (TyName uname (Just (TyCUnion (Just (Id ("tag"++uname))) fields Nothing))) case fields of ((_,_,[Id "hInproc"]):(_,_, [Id "hRemote"]):_) -> return (TyInteger Long) _ -> ret_un_ty TKIND_INTERFACE -> do iname <- typelib # typeNamed (fromIntegral index) return (TyIface iname) --(TyPointer (TyIface iname)) -- the [default] interface, really. TKIND_COCLASS -> do cname <- typelib # typeNamed (fromIntegral index) {- Life is never boring when you're writing a typelib reader... Some typelibs contain types that refer to the coclass, which doesn't make much sense, so we pick the [default] interface of the class and use that as the type. -} cocl <- typeinfoRef # readCoClass cname level typeAttr let (Attributed _ (CoClass _ mems)) = cocl iname = case filter (isDefaultIface) mems of [] -> cname ((_, Id i, _):_) -> i isDefaultIface (_,_,attrs) = hasAName "default" attrs && not (hasAName "source" attrs) hasAName _ [] = False hasAName nm ((Attrib (Id i) _):ls) = i == nm || hasAName nm ls hasAName nm (_:xs) = hasAName nm xs return (TyIface iname) --(TyPointer (TyIface iname)) TKIND_DISPATCH -> do iname <- typelib # typeNamed (fromIntegral index) return (TyIface iname) --(TyPointer (TyIface iname)) TKIND_ALIAS -> do nm <- typelib # typeNamed (fromIntegral index) aliasType <- typeinfoRef # readType level (tdescAlias typeAttr) return (TyName nm (Just aliasType)) _ -> do giveWarning level ["unexpected user defined type encountered, assume void*"] return (TyPointer TyVoid)) ( \ _ -> do giveWarning level [ "failed to unswizzle type info from typelib; treat it as void*"] return (TyPointer TyVoid)) libs_seen_ref :: IORef [String] libs_seen_ref = unsafePerformIO (newIORef []) typeNamed :: Int32 -> ITypeLib a -> IO String typeNamed index typelib = typelib # getItemName index ----------------------------------------------------------- -- Extend ITypeLib with easy name retrieval ----------------------------------------------------------- getLibName :: ITypeLib a -> IO (String, String, Word32, String) getLibName typelib = typelib # getDocumentationTL (-1) getItemName :: Int32 -> ITypeLib a -> IO String getItemName index typelib = do (name,_,_,_) <- typelib # getDocumentationTL index return name getMemberName :: Int32 -> ITypeInfo a -> IO Name getMemberName index typeinfo = do (name,_,_,_) <- typeinfo # getDocumentation index return name ----------------------------------------------------------- -- Utils ----------------------------------------------------------- getHelpAttributesTI :: Int -> ITypeInfo a -> IO (String, String, Word32, String, Word32, String) getHelpAttributesTI index typeinfo = do (libName, docString, hContext, hString) <- typeinfo # getDocumentation (fromIntegral index) (hStringContext, hStringDll) <- catch ( do typeinfo2 <- typeinfo # queryInterface iidITypeInfo2 (_,ctxt, dlln) <- typeinfo2 # getDocumentation2 (-1) lOCALE_USER_DEFAULT return (ctxt, dlln)) ( \ _ -> return (0,"")) return (libName, docString, hContext, hString, hStringContext, hStringDll) getCustomTL :: ITypeLib a -> IO [Attribute] getCustomTL typelib = do citems <- catch (do typelib2 <- typelib # queryInterface iidITypeLib2 (TagCUSTDATA cs) <- typelib2 # getAllCustDataTL return cs) (\ _ -> return []) mapM toCustom citems getCustomTI :: ITypeInfo a -> IO [Attribute] getCustomTI itypeinfo = do citems <- catch (do itypeinfo2 <- itypeinfo # queryInterface iidITypeInfo2 (TagCUSTDATA cs) <- itypeinfo2 # getAllCustData return cs) (\ _ -> return []) mapM toCustom citems toCustom :: CUSTDATAITEM -> IO Attribute toCustom ci = do (pstr,_) <- readVarString (varValue ci) str <- readBSTR (castPtr pstr) return (Attrib (Id "custom") [ AttrLit (GuidLit [show (guid0 ci)]) , AttrLit (StringLit str) ]) \end{code} ----------------------------------------------------------- -- Warnings ----------------------------------------------------------- \begin{code} giveWarning :: Level -> [String] -> IO () giveWarning level msg = hPutStrLn stderr ("warning: at '" ++ showLevel level ++ "': " ++ showMsg msg ++ "\n") where showMsg xs = concat (map ("\n "++) xs) showLevel [] = "" showLevel (x:xs) = x ++ concat (map ("."++) xs) isSet :: (Eq a, Bits a) => a -> a -> b -> Maybe b isSet val flag yes | val .&. flag == flag = Just yes | otherwise = Nothing isSetMb :: (Eq a, Bits a) => a -> a -> Maybe b -> Maybe b isSetMb val flag yes | val .&. flag == flag = yes | otherwise = Nothing isn'tSet :: (Num a, Eq a, Bits a) => a -> a -> b -> Maybe b isn'tSet val flag no | val .&. flag == 0 = Just no | otherwise = Nothing uuidAttribute :: Com.GUID -> Attribute uuidAttribute g = Attrib (Id "uuid") [AttrLit (LitLit g_sans_braces)] where g_sans_braces = tail (init (show g)) -- horror horror -- [Why? Isn't this just checking whether TYPEFLAG_FDUAL is set? -- sof] isDual :: TYPEATTR -> Bool isDual typeAttr = dualBitSet (wTypeFlags typeAttr) dualBitSet :: Word16 -> Bool dualBitSet v = v .&. 0x40 == 0x40 END_SUPPORT_TYPELIBS -} \end{code}