% 
% (c) The Foo Project, University of Glasgow 1998
%
% @(#) $Docid: Jun. 6th 2003  16:35  Sigbjorn Finne $
% @(#) $Contactid: sof@galois.com $
%

Generating type libraries from Core IDL.

\begin{code}
module TLBWriter ( writeTLB ) where

import CoreIDL
{- BEGIN_SUPPORT_TYPELIBS 
import IO
import BasicTypes
import System.IO
import Bits
import Monad ( when )
import List  ( intersperse, partition )
import PpCore

import Attribute
import Literal
import CoreUtils
import Int
import Word
import Monad
import Maybe ( isJust, fromMaybe )
import Utils ( safe_init, notNull )
import TypeInfo

-- tricking mkdependHS
import 
       HDirect
import
       WideString
import 
       Com	   hiding (GUID)
import qualified
       Com         ( GUID )
import 
       Automation  hiding (GUID,DISPID, Member)
import
       AutoPrim    ( writeVarInt, writeVarString )
import 
       TypeLib
import Foreign.Ptr
  END_SUPPORT_TYPELIBS -}
\end{code}

\begin{code}
writeTLB :: [String] -> [Decl] -> IO ()
{- BEGIN_NOT_SUPPORT_TYPELIBS -}
writeTLB _ _ = ioError (userError ("writeTLB: type library writer code not compiled in"))
{- END_NOT_SUPPORT_TYPELIBS -}

{- BEGIN_SUPPORT_TYPELIBS 
-- to the end of the file.
\end{code}

\begin{code}
writeTLB ofnames decls = do
   case interesting_decls of 
	-- If one library is present, write it out to 
	-- the type library file name given last on the command line.
     []  -> return ()
     [x] -> 
       case ofnames of
         (_:_) -> wTLB (Just (last ofnames)) x
	 _     -> wTLB Nothing x -- whatever the default name is.
     _   -> 
       mapM_ (wTLB Nothing) interesting_decls
 where
  interesting_decls = filter ofInterest decls

  ofInterest (Library _ _) = True
  ofInterest _	           = False 
  
wTLB :: Maybe String -> Decl -> IO ()
wTLB ofname decl = do
      setupTyInfoCache  -- ahem.
#ifdef DEBUG
      hPutStrLn stderr ("wTLB: " ++ show ofname) >> hFlush stderr
#endif
      plib <- (createTypeLib tlib_nm `catch` \ _ -> ioError (userError ("couldn't load: " ++ tlib_nm)))
      plib # setTLBAttrs decl
      catch 
        (do
	  plib2 <- plib # queryInterface iidICreateTypeLib2
	  setCustInfo (\ x y -> plib2 # setCustDataCTL x y) tlib_id)
        (\ _ -> return ())
#ifdef DEBUG
      hPutStrLn stderr ("wTLB: " ++ show ofname) >> hFlush stderr
#endif
      mapM_ (\ x -> plib # writeDecl x) tlib_decls
#ifdef DEBUG
      hPutStrLn stderr ("wTLB: " ++ show ofname) >> hFlush stderr
#endif
      plib # saveAllChanges
#ifdef DEBUG
      hPutStrLn stderr ("wTLB: " ++ show ofname) >> hFlush stderr
#endif
      return ()
   where
    tlib_id    = declId decl

    tlib_nm    = 
	case ofname of
	  Nothing -> idOrigName tlib_id ++ ".tlb"
	  Just x  -> x

    tlib_decls = sortDecls (declDecls decl)

setTLBAttrs :: Decl -> ICreateTypeLib a -> IO ()
setTLBAttrs decl typelib = do
  setHelpInfo (\ x -> typelib # setDocStringCTL x)
	      (\ x -> typelib # setHelpContextCTL x) 
	      i
  setGuidInfo (\ x -> typelib # setGuidCTL x) i
  typelib # setLibFlags (fromIntegral lib_flags)

  when (lcid /= ((-1)::Int)) 
       (typelib # setLcid (fromIntegral lcid))

  tlib_nm_wide <- stringToWide tlib_nm
  typelib # setNameCTL tlib_nm_wide
  setVersionInfo (\ maj min -> typelib # setVersionCTL maj min)
		 i
 where
  i       = declId decl
  attrs   = idAttributes i
  tlib_nm = idOrigName i

  lib_flags = controlFlag + restrictedFlag + hiddenFlag

  controlFlag
    | attrs `hasAttributeWithName` "control" = fromEnum LIBFLAG_FCONTROL
    | otherwise				     = 0

  restrictedFlag
    | attrs `hasAttributeWithName` "restricted" = fromEnum LIBFLAG_FRESTRICTED
    | otherwise				        = 0

  hiddenFlag
    | attrs `hasAttributeWithName` "hidden"   = fromEnum LIBFLAG_FHIDDEN
    | otherwise				      = 0

  lcid = 
     case findAttribute "lcid" attrs of
       Just (Attribute _ [ParamLit (IntegerLit (ILit _ x))]) -> (fromIntegral x)
       _					      -> ((-1)::Int)


\end{code}

\begin{code}
writeDecl :: Decl -> ICreateTypeLib a -> IO ()
writeDecl d typelib = 
  case d of
    Typedef{}           -> typelib # writeTypedef d 
     -- Constants are only handled within modules,
     -- so writeModule takes care of filtering these out
     -- and writing 'em out.
    Constant{}          -> return ()
    Interface{}         -> typelib # writeInterface d
    DispInterface{}     -> typelib # writeDispInterface d 
    CoClass{}           -> typelib # writeCoClass d 
    Module{}            -> typelib # writeModule d 
    _ 			-> return ()
 where
   -- currently unused, all typedefs are exported.
  -- hasPublicAttr i = (idAttributes i) `hasAttributeWithName` "public"

\end{code}

\begin{code}
writeTypedef :: Decl -> ICreateTypeLib a -> IO ()
writeTypedef (Typedef i t o) typelib
  | isConstructedUnionTy = do
	case unionToStruct t of
	  (Nothing, t')       -> typelib # writeTypedef (Typedef i t' o) 
	  (Just (u_i,u_t), s_t) -> do
	      typelib # writeTypedef (Typedef u_i u_t o)
	      typelib # writeTypedef (Typedef i s_t o)
  | isConstructedTy = do
      wstr    <- stringToWide (idOrigName i)
#ifdef DEBUG
      hPutStrLn stderr ("writeTypedef: " ++ show (idOrigName i)) >> hFlush stderr
#endif
      tinfo1  <- typelib # createTypeInfo wstr tkind
      itinfo1 <- tinfo1  # queryInterface iidITypeInfo
      addTyInfo (idOrigName i) itinfo1
      addTyInfo (idName i) itinfo1
      tinfo1 # (case tkind of
		  TKIND_ENUM   -> writeEnum t
		  TKIND_RECORD -> writeRecord t typelib
		  TKIND_UNION  -> writeUnion t typelib)
      setHelpInfo (\ x -> tinfo1 # setDocString x)
	          (\ x -> tinfo1 # setHelpContext x)
	          i
      catch 
        (do
	  ti <- tinfo1 # queryInterface iidICreateTypeInfo2
	  setCustInfo (\ x y -> ti # setCustData x y) i)
        (\ _ -> return ())
      tinfo1 # layOut
      return ()

  | otherwise = do
      wstr  <- stringToWide (idOrigName i)
      tinfo <- typelib # createTypeInfo wstr TKIND_ALIAS
      itinfo1 <- tinfo # queryInterface iidITypeInfo
      addTyInfo (idOrigName i) itinfo1
      addTyInfo (idName i) itinfo1
      tinfo # setTypeDescAlias (typedesc typelib tinfo t)
      setHelpInfo (\ x -> tinfo # setDocString x)
	          (\ x -> tinfo # setHelpContext x)
	          i
      catch 
        (do
	  ti <- tinfo # queryInterface iidICreateTypeInfo2
	  setCustInfo (\ x y -> ti # setCustData x y) i)
        (\ _ -> return ())
      tinfo # layOut
      return ()
 where
  (isConstructedTy, isConstructedUnionTy, tkind) =
    case t of
      Struct{}   -> (True, False, TKIND_RECORD)
      Union{}    -> (True, True,  TKIND_UNION)
      UnionNon{} -> (True, True,  TKIND_UNION)
      CUnion{}	 -> (True, False, TKIND_UNION)
      Enum{}	 -> (True, False, TKIND_ENUM)
      _		 -> (False, False, TKIND_MAX)

typedesc :: ICreateTypeLib b -> ICreateTypeInfo a -> Type -> TYPEDESC
typedesc tlib ti t =  
  case t of
      Float Short	 -> simpleDesc VT_R4
      Float Long	 -> simpleDesc VT_R8
      Integer Short signed
         | signed    -> simpleDesc VT_I2
         | otherwise -> simpleDesc VT_UI2
      Integer Long  signed
         | signed    -> simpleDesc VT_I4
         | otherwise -> simpleDesc VT_UI4
      Integer Natural  signed
         | signed    -> simpleDesc VT_I4
         | otherwise -> simpleDesc VT_UI4
      Integer LongLong  signed
         | signed    -> simpleDesc VT_I8
         | otherwise -> simpleDesc VT_UI8
      Char False	 -> simpleDesc VT_UI1
      Char True		 -> simpleDesc VT_I1
      WChar		 -> simpleDesc VT_I2  -- in line with what MIDL does.
      String{}		 -> simpleDesc VT_LPSTR
      WString{} 	 -> simpleDesc VT_LPWSTR
      Void		 -> simpleDesc VT_VOID
      SafeArray ty	 -> 
	    let td = typedesc tlib ti ty in
	    TagTYPEDESC (Lptdesc (Just td))
			(fromIntegral (fromEnum VT_SAFEARRAY))
      Array ty bnds       -> 
	    let td   = typedesc tlib ti ty
		lens = map (fromIntegral.evalExpr) bnds
	        ad   = TagARRAYDESC td (map (\ x -> TagSAFEARRAYBOUND (fromIntegral x) 0)
					    lens)
	    in
	    
	    TagTYPEDESC (Lpadesc (Just ad))
			(fromIntegral (fromEnum VT_CARRAY))
      Name "VARIANT" _ _ _ _ _ -> simpleDesc VT_VARIANT
      Name _ "VARIANT" _ _ _ _ -> simpleDesc VT_VARIANT
      Name "IHC_TAG_3" _ _ _ _ _ -> simpleDesc VT_VARIANT
      Name "HRESULT" _ _ _ _ _ -> simpleDesc VT_HRESULT
      Pointer _ _ ty	   -> ptrDesc (typedesc tlib ti ty)
      Name nm _ _ _ origTy mb_ti ->
        case lookupTyInfo nm of
	  Just it -> unsafePerformIO $ do -- proof obligation! :)
	     hr <- ti # addRefTypeInfo it
	     return (TagTYPEDESC (Hreftype hr) (fromIntegral (fromEnum VT_USERDEFINED)))
	  Nothing -> unsafePerformIO $
	     case mb_ti of
	       Just tyinfo | isJust (auto_vt tyinfo) -> do
		let (Just vt) = auto_vt tyinfo
		return (simpleDesc vt)
	       _ -> do
  	        hPutStrLn stderr ("failed to find: " ++ show nm)
	        case origTy of
	          Nothing -> do
		    hPutStrLn stderr ("..and it's type expansion. That's a shame - interpreting it as a VARIANT*")
		    return (simpleDesc VT_VARIANT) -- ToDo: emit *warning/error*
	          Just e_t  -> do
 	            hPutStrLn stderr ("but found type expansion - everything's cool.")
                    tlib # writeDecl (Typedef (mkId nm nm Nothing []) e_t e_t)
		     -- retry...shouldn't loop, but if it does the user will see..
		    return (typedesc tlib ti t)
      Iface nm _ _ _ _ _ ->
		case lookupTyInfo nm of
		    Just it -> unsafePerformIO $ do -- proof obligation! :)
			hr <- ti # addRefTypeInfo it
			return (TagTYPEDESC (Hreftype hr) (fromIntegral (fromEnum VT_USERDEFINED)))
		    Nothing -> simpleDesc VT_UNKNOWN -- ToDo: emit *warning/error*
      _ -> error ("typedesc: can't handle " ++ showCore (ppType t))

 where	    			
  ptrDesc td = TagTYPEDESC (Lptdesc (Just td))
			   (fromIntegral (fromEnum VT_PTR))

  simpleDesc x = TagTYPEDESC IHC_TAG_3_Anon (fromIntegral (fromEnum x))

\end{code}

An enumeration is stored as a set of constant values:

\begin{code}
writeEnum :: Type -> ICreateTypeInfo a -> IO ()
writeEnum (Enum i _ vals) tinfo = do
#ifdef DEBUG
  hPutStrLn stderr ("writeEnum: " ++ show (idOrigName i)) >> hFlush stderr
#endif
  sequence (map writeEnumTag (zip [(0::Word32)..] vals))
  tinfo # setTypeFlags tflags
  setGuidInfo (\ x -> tinfo # setGuid x) i
  setHelpInfo (\ x -> tinfo # setDocString x)
	      (\ x -> tinfo # setHelpContext x)
	      i
  setVersionInfo (\ maj min -> tinfo # setVersion maj min)
		 i
  catch 
    (do
      ti <- tinfo # queryInterface iidICreateTypeInfo2
      setCustInfo (\ x y -> ti # setCustData x y) i)
    (\ _ -> return ())
  return ()
 where
  writeEnumTag (index, val) = do
    tinfo # addVarDesc index vardesc
    wstr <- stringToWide (idName (enumName val))
    tinfo # setVarName index wstr
     -- helpstrings on enum tags..nothing's stopping us, I suppose..
    setHelpInfo (\ x -> tinfo # setVarDocString index x)
	        (\ x -> tinfo # setVarHelpContext index x) 
	        (enumName val)
    catch 
      (do
        ti <- tinfo # queryInterface iidICreateTypeInfo2
        setCustInfo (\ x y -> ti # setVarCustData index x y) i)
      (\ _ -> return ())
    return ()
   where
    vardesc = TagVARDESC (fromIntegral index) nullWideString 
			 (LpvarValue (Just v)) ed 0 VAR_CONST
    ed = TagELEMDESC td pd
     --ToDo: honour v1_enum (or its abscence, as the case might be here.)
    td = TagTYPEDESC IHC_TAG_3_Anon (fromIntegral (fromEnum VT_I4))
    pd = TagPARAMDESC Nothing 0
    v  = unsafePerformIO $ 
	 case (enumValue val) of
	    Left value -> do
		var <- allocBytes (fromIntegral sizeofVARIANT)
		writeVarInt value var
		return var
	    Right e -> do
		var <- allocBytes (fromIntegral sizeofVARIANT)
		writeVarInt (fromIntegral (evalExpr e)) var
		return var

  tflags = computeTypeFlags i


\end{code}

\begin{code}
writeRecord :: Type -> ICreateTypeLib b -> ICreateTypeInfo a -> IO ()
writeRecord s_ty@(Struct i fields _) typelib tinfo = do
  let (_,offs) = computeStructSizeOffsets Nothing fields
  zipWithM_ writeField [0..] (zip offs fields)
  tinfo # setTypeFlags tflags
  setGuidInfo (\ x -> tinfo # setGuid x) i
  setHelpInfo (\ x -> tinfo # setDocString x)
	      (\ x -> tinfo # setHelpContext x)
	      i
  setVersionInfo (\ maj min -> tinfo # setVersion maj min)
		 i
  tinfo # setAlignment (fromIntegral struct_align)
  catch 
        (do
	  tinfo2 <- tinfo # queryInterface iidICreateTypeInfo2
	  setCustInfo (\ x y -> tinfo2 # setCustData x y) i)
        (\ _ -> return ())
   -- writeTypedef will call 'layOut' for us.
  return ()
 where
  tflags = computeTypeFlags i
  
   -- hmm, might we run into unwanted problems here?
   -- If so, define 'struct_align' to be 1 so as to
   -- make it the 'natural' alignment.
  (_, struct_align) = sizeAndAlignModulus Nothing s_ty

  writeField idx (off, field) = do
    tinfo # addVarDesc idx vardesc
    wstr <- stringToWide (idOrigName (fieldId field))
    tinfo # setVarName idx wstr
    setHelpInfo (\ x -> tinfo # setVarDocString idx x)
	        (\ x -> tinfo # setVarHelpContext idx x) 
	        i
    catch 
        (do
	  tinfo2 <- tinfo # queryInterface iidICreateTypeInfo2
	  setCustInfo (\ x y -> tinfo2 # setVarCustData idx x y) i)
        (\ _ -> return ())
    return ()
   where
    vardesc = TagVARDESC (fromIntegral idx) nullWideString 
			 (OInst (fromIntegral off)) ed wflags VAR_PERINSTANCE
    ed      = TagELEMDESC td pd
    td      = typedesc typelib tinfo (fieldType field)
    pd      = TagPARAMDESC Nothing 0
    wflags  = computeVarFlags (fieldId field)

\end{code}

\begin{code}
writeUnion :: Type -> ICreateTypeLib b -> ICreateTypeInfo a -> IO ()
writeUnion (CUnion i fields _) typelib tinfo = do
  zipWithM_ writeField [0..] fields
  tinfo # setTypeFlags tflags
  setGuidInfo (\ x -> tinfo # setGuid x) i
  setHelpInfo (\ x -> tinfo # setDocString x)
	      (\ x -> tinfo # setHelpContext x)
	      i
  setVersionInfo (\ maj min -> tinfo # setVersion maj min)
		 i
  tinfo # setAlignment 1 --(fromIntegral struct_align)
  catch 
        (do
	  tinfo2 <- tinfo # queryInterface iidICreateTypeInfo2
	  setCustInfo (\ x y -> tinfo2 # setCustData x y) i)
        (\ _ -> return ())
   -- writeTypedef will call 'layOut' for us.
  return ()
 where
  tflags = computeTypeFlags i
  
   -- hmm, might we run into unwanted problems here?
   -- If so, define 'struct_align' to be 1 so as to
   -- make it the 'natural' alignment.
--  (_, struct_align) = sizeAndAlignModulus Nothing s_ty

  writeField idx field = do
    tinfo # addVarDesc idx vardesc
    wstr <- stringToWide (idOrigName (fieldId field))
    tinfo # setVarName idx wstr
    setHelpInfo (\ x -> tinfo # setVarDocString idx x)
	        (\ x -> tinfo # setVarHelpContext idx x) 
	        i
    catch 
        (do
	  tinfo2 <- tinfo # queryInterface iidICreateTypeInfo2
	  setCustInfo (\ x y -> tinfo2 # setVarCustData idx x y) i)
        (\ _ -> return ())
    return ()
   where
    vardesc = TagVARDESC (fromIntegral idx) nullWideString 
			 (OInst 0) ed wflags VAR_PERINSTANCE
    ed      = TagELEMDESC td pd
    td      = typedesc typelib tinfo (fieldType field)
    pd      = TagPARAMDESC Nothing 0
    wflags  = computeVarFlags (fieldId field)

writeUnion _ _ _ = return ()
\end{code}

\begin{code}
writeInterface :: Decl -> ICreateTypeLib a -> IO ()
writeInterface (Interface i is_ref inherits decls) typelib 
 | is_ref    = return ()
 | otherwise = do
  wstr   <- stringToWide (idOrigName i)
  tinfo <- typelib # createTypeInfo wstr TKIND_INTERFACE
    -- stash away the ITypeInfo for later references to this
    -- iface to make use of.
  ti    <- tinfo # queryInterface iidITypeInfo
  addTyInfo (idOrigName i) ti
  let (ms, non_ms) = partition isMethod decls
  let (_, non_cs)  = partition isConst non_ms
    -- lift the non-method/const decls out to the top (notably tydefs.)
    -- Do these first since the methods may refer to the typedefs, so
    -- their names had better be in the ITypeInfo-cache.
    --
  tinfo # setInherit inherits
  mapM_ (\ x -> typelib # writeDecl x) non_cs
  zipWithM_ (writeMethod True Nothing typelib tinfo) [0..] ms
    -- we blatantly ignore constants inside interface{}s
    -- (as does MIDL), as the typelib format ain't up to it.
    -- Oh well, no one will notice..
  tinfo # setTypeFlags tflags
  setGuidInfo (\ x -> tinfo # setGuid x) i
  setHelpInfo (\ x -> tinfo # setDocString x)
	      (\ x -> tinfo # setHelpContext x)
	      i
  setVersionInfo (\ maj min -> tinfo # setVersion maj min)
		 i
  catch 
      (do
        tin <- tinfo # queryInterface iidICreateTypeInfo2
        setCustInfo (\ x y -> tin # setCustData x y) i)
      (\ _ -> return ())
  tinfo # layOut
  return ()
 where
  attrs = idAttributes i

  isDual = attrs `hasAttributeWithName` "dual" 

  is_idispatchy = 
    isDual || "IDispatch" `elem` map (qName.fst) inherits

  tflags =
    (ifSet (tflags_raw .&. (fromEnum32 TYPEFLAG_FDUAL) /= 0)
           (fromEnum32 TYPEFLAG_FOLEAUTOMATION)) .|.
    (ifSet is_idispatchy 
           (fromEnum32 TYPEFLAG_FDISPATCHABLE)) .|.
    tflags_raw

  tflags_raw = computeTypeFlags i
\end{code}

\begin{code}
paramDesc :: Param -> PARAMDESC
paramDesc p = TagPARAMDESC desc_ex flags
 where
  attrs = idAttributes (paramId p)

  has_def_val = attrs `hasAttributeWithName` "defaultvalue"

  flags = 
    ifSet (attrs `hasAttributeWithName` "lcid")         pARAMFLAG_FLCID       .|.
    ifSet (attrs `hasAttributeWithName` "retval")       pARAMFLAG_FRETVAL     .|.
    ifSet (attrs `hasAttributeWithName` "optional")     pARAMFLAG_FOPT        .|.
    ifSet has_def_val					pARAMFLAG_FHASDEFAULT .|.
    (case (paramMode p) of
      In    -> pARAMFLAG_FIN
      Out   -> pARAMFLAG_FOUT
      InOut -> pARAMFLAG_FOUT .|. pARAMFLAG_FIN)
    
  desc_ex 
   | has_def_val = Just (TagPARAMDESCEX 24 def_var)
   | otherwise   = Nothing

  def_var =
       case findAttribute "defaultvalue" attrs of
         Just (Attribute _ [ParamLit (StringLit  x)]) -> unsafePerformIO $ do
			p_bstr <- marshallBSTR x
	                var    <- allocBytes (fromIntegral sizeofVARIANT)
	                writeVarString (castPtr p_bstr) var -- poorly named, should be writeVarBSTR
	                return var
         Just (Attribute _ [ParamLit (IntegerLit (ILit _ x))]) -> unsafePerformIO $ do
		       var <- allocBytes (fromIntegral sizeofVARIANT)
		       writeVarInt (fromIntegral x) var
		       return var
	 _ -> unsafePerformIO $ do
            var <- allocBytes (fromIntegral sizeofVARIANT)
            writeVarInt 0 var
            return var

\end{code}

Deceptively similar to what's done for an 'interface'; record
properties as 'variables' (via writeProp).

\begin{code}
writeDispInterface :: Decl -> ICreateTypeLib a -> IO ()
writeDispInterface (DispInterface i ii props meths) typelib = do
  wstr   <- stringToWide (idOrigName i)
  tinfo <- typelib # createTypeInfo wstr TKIND_DISPATCH
  tinfo # setTypeFlags tflags
    -- stash away the ITypeInfo for later references to this
    -- iface to make use of.
  ti    <- tinfo # queryInterface iidITypeInfo
  addTyInfo (idOrigName i) ti
  mapM_ (writeProp typelib tinfo) props
  (case lookupTyInfo "IDispatch" of
        Nothing -> return ()
        Just it -> do
	     hr <- tinfo # addRefTypeInfo it
	     tinfo # addImplType 0 hr
	     return ())
  (case ii of
     Just (Interface{declId=id}) ->
      case lookupTyInfo (idName id) of
        Nothing -> 
	  let nm = idName id in
	  hPutStrLn stderr ("Help - inherited from interface: " ++ show nm ++
			    " , but couldn't find its ITypeInfo")
        Just it -> do
	     hr <- tinfo # addRefTypeInfo it
	     tinfo # addImplType 1 hr
	     return ()
     _ -> return ())
  when (not (isJust ii)) (zipWithM_ (writeMethod False Nothing typelib tinfo) [0..] meths)
  setVersionInfo (\ maj min -> tinfo # setVersion maj min)
		 i
  setGuidInfo (\ x -> tinfo # setGuid x) i
  setHelpInfo (\ x -> tinfo # setDocString x)
	      (\ x -> tinfo # setHelpContext x)
	      i
  catch 
      (do
        tin <- tinfo # queryInterface iidICreateTypeInfo2
        setCustInfo (\ x y -> tin # setCustData x y) i)
      (\ _ -> return ())
  tinfo # layOut
  return ()
 where
   -- SetTypeFlags() barfs if you pass it this for a dispinterface.
   -- Beats me why it needs to be so strict.
  tflags = tflags_raw .&. (complement (fromIntegral (fromEnum TYPEFLAG_FOLEAUTOMATION)))
  tflags_raw = computeTypeFlags i

\end{code}

\begin{code}
writeCoClass :: Decl -> ICreateTypeLib a -> IO ()
writeCoClass (CoClass i ds) typelib = do
    wstr  <- stringToWide (idOrigName i)
    tinfo <- typelib # createTypeInfo wstr TKIND_COCLASS
    setGuidInfo (\ x -> tinfo # setGuid x) i
    foldM (writeCoClassDecl tinfo) 0 ds
    tinfo # setTypeFlags c_flags
    setVersionInfo (\ maj min -> tinfo # setVersion maj min)
		   i
    setHelpInfo (\ x -> tinfo # setDocString x)
		(\ x -> tinfo # setHelpContext x)
		i
    catch 
      (do
        ti <- tinfo # queryInterface iidICreateTypeInfo2
        setCustInfo (\ x y -> ti # setCustData x y) i)
      (\ _ -> return ())
    tinfo # layOut
    return ()
  where
   attrs = idAttributes i

   writeCoClassDecl tinfo idx d = 
       let nm = idOrigName (coClassId d) in
       case lookupTyInfo nm of
         Nothing -> do
	    hPutStrLn stderr ("writeCoClass: Warning - couldn't find type info for " ++ show nm)
	    case (coClassDecl d) of
	      Nothing -> return idx
	      Just de -> do
	          typelib # writeDecl de
		    -- it should have been added to the cache by now.
		  writeCoClassDecl tinfo idx d
	 Just it -> do
	    hr <- tinfo # addRefTypeInfo it
	    tinfo # addImplType idx hr
	    tinfo # setImplTypeFlags idx d_flags
            catch 
                 (do
                   ti <- tinfo # queryInterface iidICreateTypeInfo2
                   setCustInfo (\ x y -> ti # setImplTypeCustData idx x y) i)
                 (\ _ -> return ())
	    return (idx+1)
      where
	i_attrs = idAttributes (coClassId d)

	d_flags :: Int32
        d_flags = 
           foldr (\ (nm, val) acc -> ifSet (i_attrs `hasAttributeWithName` nm) val .|. acc) 
	         0
	         [ ("default", 0x1)
	         , ("source",  0x2)
	         , ("restricted", 0x4)
	         , ("defaultvtable", 0x800)
	         ]

   c_flags  :: Word32
   c_flags
    | attrs `hasAttributeWithName` "noncreatable" = c_flags'
    | otherwise					  = c_flags' .|. 0x02

   c_flags' :: Word32
   c_flags' = computeTypeFlags i

\end{code}

\begin{code}
writeModule :: Decl -> ICreateTypeLib a -> IO ()
writeModule (Module i ds) typelib = do
    wstr  <- stringToWide (idOrigName i)
    tinfo <- typelib # createTypeInfo wstr TKIND_MODULE
    setGuidInfo (\ x -> tinfo # setGuid x) i
    tinfo # setTypeFlags m_flags
    setVersionInfo (\ maj min -> tinfo # setVersion maj min)
	   i
    setHelpInfo (\ x -> tinfo # setDocString x)
		(\ x -> tinfo # setHelpContext x)
		i
    let (ms, non_ms) = partition isMethod ds
    let (cs, non_cs) = partition isConst non_ms
     -- MIDL magically lifts typedefs out of a module{} in 
     -- the tlb it generates. So, to follow suit, do we.
    mapM_ (\ x -> typelib # writeDecl x) non_cs
    zipWithM_ (writeMethod False (Just dllname) typelib tinfo) [0..] ms
    zipWithM_ (writeConst typelib tinfo) [0..] cs
    catch 
        (do
	  tinfo2 <- tinfo # queryInterface iidICreateTypeInfo2
	  setCustInfo (\ x y -> tinfo2 # setCustData x y) i)
        (\ _ -> return ())
    tinfo # layOut

  where
   m_flags = computeTypeFlags i

   dllname = 
       case findAttribute "dllname" (idAttributes i) of
         Just (Attribute _ [ParamLit (StringLit  x)]) -> x
	 _ -> ""

\end{code}

Writing out methods in (disp)interfaces:

\begin{code}
writeMethod :: Bool -> Maybe String -> ICreateTypeLib b -> ICreateTypeInfo a -> Word32 ->  Decl -> IO ()
writeMethod isBinary hasDllName typelib tinfo idx (Method f cc res params _) = do
   tinfo # addFuncDesc idx fdesc
   wnames <- mapM stringToWide names
   tinfo # setFuncAndParamNames idx wnames
   setHelpInfo (\ x -> tinfo # setFuncDocString idx x)
	       (\ x -> tinfo # setFuncHelpContext idx x)
	       f
   when isDllMethod $ do
      w_dll   <- stringToWide dllname
       -- Why, oh why - if the high word of w_entry
       -- is zero, then the low word contains the DLL ordinal. If not,
       -- it contains the entry name. Lovely.
      w_entry <- 
	  if isOrdinal then
	     word16ToWideString ordinal
	  else
	     stringToWide entry
      tinfo # defineFuncAsDllEntry idx w_dll w_entry
    -- set custom attributes for the method...
   catch 
        (do
	  tinfo2 <- tinfo # queryInterface iidICreateTypeInfo2
	  setCustInfo (\ x y -> tinfo2 # setCustData x y) f)
        (\ _ -> return ())
    -- ...and for its parameters.
   catch 
        (do
          ti <- tinfo # queryInterface iidICreateTypeInfo2
	  let
	    setParamCust i p = 
	       setCustInfo (\ x y -> ti # setParamCustData idx i x y) (paramId p)
	  zipWithM_ setParamCust [0..] params)
        (\ _ -> return ())
   return ()
  where
      -- Oh yeah, the last parameter of put and putref accessors are unnamed.
      -- Why? Beats me, but it produced some interesting swearwords at the moment
      -- it was discovered that this was why writeMethod was failing!
      -- 
     names       = idOrigName f : (if isPropPut then safe_init param_names else param_names)
     param_names = map (idOrigName.paramId) params

     attrs = idAttributes f

     (entry, ordinal, isOrdinal) =
       case findAttribute "entry" attrs of
         Just (Attribute _ [ParamLit (IntegerLit (ILit _ x))]) -> ("", fromIntegral x, True)
         Just (Attribute _ [ParamLit (StringLit  x)])          -> (x, 0, False)
	 _ -> ("", 0, True)
      

     isDllMethod    = isJust hasDllName
     (Just dllname) = hasDllName

     fkind
      | isBinary    = FUNC_PUREVIRTUAL
      | isDllMethod = FUNC_STATIC
      | otherwise   = FUNC_DISPATCH

     fdesc = 
       TagFUNCDESC memid [] elemdesc_params
		   fkind invkind
		   cc_fd no_opt_params ovft
		   elemdesc_res f_flags
		   
     ovft
      | isDllMethod = fromIntegral memid
      | otherwise   = fromIntegral mEMBER_NULL

     memid 
       | not isDllMethod = 
          case findAttribute "id" attrs of
	    Just (Attribute _ [ParamLit (IntegerLit (ILit _ x))]) -> fromIntegral x
	    _ -> fromIntegral idx

	 -- This one is odd, for some reason the memberid has be an offset of
	 -- the below value. I can't make out why bits 2 and 3 of the msb
	 -- needs to be set just from looking at the docs for a MEMBERID. 
	 -- (I figured this one out by peering at the memid fields produced
	 -- by MIDL.)
       | otherwise = fromIntegral (0x60000000 + fromIntegral idx)

     (invkind , isPropPut)
       | attrs `hasAttributeWithName` "propget"    = (INVOKE_PROPERTYGET, False)
       | attrs `hasAttributeWithName` "propput"    = (INVOKE_PROPERTYPUT, True)
       | attrs `hasAttributeWithName` "propputref" = (INVOKE_PROPERTYPUTREF, True)
       | otherwise				   = (INVOKE_FUNC, False)

     elemdesc_params = 
        map (\ p -> TagELEMDESC (typedesc typelib tinfo (paramType p))
				(paramDesc p)) params

     elemdesc_res = 
	 TagELEMDESC
	    (typedesc typelib tinfo (resultOrigType res))
	    (TagPARAMDESC Nothing 0)

     cc_fd =
       case cc of
         Stdcall  -> CC_STDCALL
	 Pascal   -> CC_PASCAL
	 Cdecl    -> CC_CDECL
	 Fastcall -> CC_FASTCALL

     no_opt_params = fromIntegral $
		     length (filter (hasOptionalAttr.idAttributes.paramId) params)
     
     hasOptionalAttr at = at `hasAttributeWithName` "optional"

     f_flags :: Word16
     f_flags =
        foldr (\ (nm, val) acc -> ifSet (attrs `hasAttributeWithName` nm) val .|. acc) 0 
	      [ ("restricted",	      0x1)
	      , ("source",	      0x2)
	      , ("bindable",	      0x4)
	      , ("requestedit",	      0x8)
	      , ("displaybind",      0x10)
	      , ("defaultbind",      0x20)
	      , ("hidden",           0x40)
	      , ("usesgetlasterror", 0x80)
	      , ("defaultcollelem", 0x100)
	      , ("uidefault",       0x200)
	      , ("nonbrowsable",    0x400)
	      , ("replaceable",     0x800)
	      , ("immediatebind",  0x1000)
	      ]

writeMethod _ _ _ _ _ _ = return ()

writeProp :: ICreateTypeLib b -> ICreateTypeInfo a -> Decl -> IO ()
writeProp typelib tinfo (Property i ty _ _ _) = do
    tinfo # addVarDesc memid vardesc
    wstr <- stringToWide (idOrigName i)
    tinfo # setVarName memid wstr
    setHelpInfo (\ x -> tinfo # setVarDocString memid x)
	        (\ x -> tinfo # setVarHelpContext memid x)
	        i
    catch 
        (do
	  tinfo2 <- tinfo # queryInterface iidICreateTypeInfo2
	  setCustInfo (\ x y -> tinfo2 # setVarCustData memid x y) i)
        (\ _ -> return ())
    return ()
 where
    attrs   = idAttributes i

    vardesc = TagVARDESC (fromIntegral (fromIntegral memid)) nullWideString 
			 (LpvarValue (Just v)) ed wflags VAR_DISPATCH
    ed = TagELEMDESC td pd
    td = typedesc typelib tinfo ty
    pd = TagPARAMDESC Nothing 0
    v  = unsafePerformIO $ do
		var <- allocBytes (fromIntegral sizeofVARIANT)
		writeVarInt 0 var
		return var
    wflags = computeVarFlags i

    memid  =
      case findAttribute "id" attrs of
        Just (Attribute _ [ParamLit (IntegerLit (ILit _ x))]) -> fromIntegral x
	_ -> 0

writeProp _ _ _ = return ()

\end{code}

\begin{code}
writeConst :: ICreateTypeLib b -> ICreateTypeInfo a -> Word32 -> Decl -> IO ()
writeConst typelib tinfo idx (Constant i ty _ e) = do
   tinfo # addVarDesc memid vardesc
   wstr <- stringToWide (idOrigName i)
   tinfo # setVarName memid wstr
   setHelpInfo (\ x -> tinfo # setVarDocString memid x)
	       (\ x -> tinfo # setVarHelpContext memid x)
	       i
   catch 
     (do
       ti <- tinfo # queryInterface iidICreateTypeInfo2
       setCustInfo (\ x y -> ti # setVarCustData memid x y) i)
     (\ _ -> return ())
   return ()
 where
    attrs   = idAttributes i

    vardesc = TagVARDESC 0 nullWideString 
			 (LpvarValue (Just v)) ed 0{-no VARFLAGS-} VAR_CONST
    ed = TagELEMDESC td pd
    td = typedesc typelib tinfo ty
    pd = TagPARAMDESC Nothing 0
    v  = unsafePerformIO $ 
	 case e of
	    Lit l -> do
	      p_bstr <- marshallBSTR (litToString l)
	      var    <- allocBytes (fromIntegral sizeofVARIANT)
	      writeVarString (castPtr p_bstr) var -- poorly named, should be writeVarBSTR
	      return var
	    _ -> do
		-- ToDo: look for other exprs.
		var <- allocBytes (fromIntegral sizeofVARIANT)
		hPutStrLn stderr "writeConst: cannot handle expr"
		writeVarInt 1 var
		return var

    memid  =
      case findAttribute "entry" attrs of
        Just (Attribute _ [ParamLit (IntegerLit (ILit _ x))]) -> fromIntegral x
	_ -> idx

writeConst _ _ _ _ = return ()

\end{code}

\begin{code}
-- Not the same as MEMBER_NIL, but the value we
-- use to fill in empty slots (which LayOut() will
-- decorate for us) with.
mEMBER_NULL :: Int16
mEMBER_NULL = 0

mEMBER_NIL :: Int16
mEMBER_NIL = (-1)

\end{code}

Given the ICreateTypeInfo for an interface and its list of
interface names it inherits from - set the inheritance
info.

In the case of it being "IUnknown" or "IDispatch", we know
their home (stdole2) and set the inheritance info accordingly.

Note: the assumption is that the ITypeInfo for any non-builtin
interfaces will have been put in the Href-cache by now. If not,
you lose.

\begin{code}
setInherit :: InterfaceInherit -> ICreateTypeInfo () -> IO ()
setInherit []         _     = return ()
setInherit ((qn,_):_) tinfo = do
     case lookupTyInfo (qName qn) of
        Nothing -> 
	  let nm = qName qn in
	  hPutStrLn stderr ("Help - inherited from interface: " ++ show nm ++
			    " , but couldn't find its ITypeInfo")
        Just it -> do
	     hr <- tinfo # addRefTypeInfo it
	     tinfo # addImplType 0 hr
	     return ()

setupTyInfoCache :: IO ()
setupTyInfoCache = do
     resetTyInfoCache
      -- create a cross-reference to IUnknown / IDispatch impl in Stdole32
     let guid    = mkGUID "{00020430-0000-0000-C000-000000000046}"
         majVer  = 2::Int
	 minVer  = 0::Int
	 lcid   =  0::Int
     tlbOle <- loadRegTypeLib guid majVer minVer lcid
     count  <- tlbOle # getTypeInfoCount
     mapM_ (addTy tlbOle) [(0::Word32)..(count-1)]
      -- some aliases.
     addTyInfo "IID" (fromMaybe (error "failed to find IID") -- 
				(lookupTyInfo "GUID"))
     addTyInfo "CLSID" (fromMaybe (error "failed to find CLSID") -- 
				  (lookupTyInfo "GUID"))
     return ()
 where 
  addTy tlb i = do
    (name,_,_,_) <- tlb # getDocumentationTL (word32ToInt32 i)
    if (ofInterest name) then do
       ti <- tlb # getTypeInfo i
       addTyInfo name ti
     else
       return ()

  ofInterest n = n `elem` prim_ls

  prim_ls = [ "IUnknown"
            , "IDispatch"
	    , "GUID"
	    ]

\end{code}

Secret mapping of type names to ITypeInfo* for types
we've already grabbed hold of. The i-pointers get mapped
to a HREFTYPE val at the point of use.

\begin{code}
tyi_refs :: IORef [(String, ITypeInfo ())]
tyi_refs = unsafePerformIO (newIORef [])

resetTyInfoCache :: IO ()
resetTyInfoCache = writeIORef tyi_refs []

addTyInfo :: String -> ITypeInfo () -> IO ()
addTyInfo nm iptr = do
  ls <- readIORef tyi_refs
  writeIORef tyi_refs ((nm, iptr):ls)

lookupTyInfo :: String -> Maybe (ITypeInfo ())
lookupTyInfo nm = unsafePerformIO $ do
  ls <- readIORef tyi_refs
  return (lookup nm ls)
\end{code}

\begin{code}
ifSet :: (Num a) => Bool -> a -> a
ifSet True x  = x
ifSet _    _  = 0

fromEnum32 :: Enum a => a -> Word32
fromEnum32 x = fromIntegral (fromEnum x)

fromEnum16 :: Enum a => a -> Word16
fromEnum16 x = fromIntegral (fromEnum x)
\end{code}

Helper functions which abstract away from methods with
identical functionality that's provided by both ICreateTypeLib
and ICreateTypeInfo.

\begin{code}
setHelpInfo :: (WideString -> IO ()) -- write out helpstring
	    -> (Word32 -> IO ())     -- write out helpcontext
	    -> Id
	    -> IO ()
setHelpInfo wr_str wr_ctxt i = do
  when (notNull doc_str) $ do
	    wstr <- stringToWide doc_str
            wr_str wstr
  when (h_ctxt /= 0) (wr_ctxt h_ctxt)
  return ()
 where
  attrs   = idAttributes i
  doc_str =
    case findAttribute "helpstring" attrs of
      Just (Attribute _ [ParamLit (StringLit str)]) -> str
      _ -> []

  h_ctxt :: Word32
  h_ctxt =
     case findAttribute "helpcontext" attrs of
       Just (Attribute _ [ParamLit (IntegerLit (ILit _ v))]) -> fromIntegral v
       _ -> 0

setVersionInfo :: (Word16 -> Word16 -> IO ())
	       -> Id
	       -> IO ()
setVersionInfo wr_version i = do
  when (isJust versionInfo) $ 
       wr_version (fromIntegral major) (fromIntegral minor)
 where   
  attrs       = idAttributes i

  versionInfo =
     case findAttribute "version" attrs of
       Just (Attribute _ [ParamLit (FloatingLit (d,_))]) -> 
		-- sigh, brittle allright.
		let (maj,min) = break (=='.') d in
		Just (read maj,read (tail min))
       _ -> Nothing

  Just (major, minor) = versionInfo

setGuidInfo :: (Com.GUID -> IO ())
	    -> Id
	    -> IO ()
setGuidInfo wr_guid i = when (notNull guid_str) 
			     (wr_guid (mkGUID guid_str))
 where
  attrs	   = idAttributes i

  guid_str = 
    case getUuidAttribute attrs of
      Just [g] -> 
        case g of
	  '{':_ -> g
	  _     -> '{':g ++ "}"
       -- shouldn't happen, but who cares.
      Just gs  -> '{':concat (intersperse "-" gs) ++ "}"
      _	       -> []

setCustInfo :: (Com.GUID -> VARIANT -> IO ())
	    -> Id
	    -> IO ()
setCustInfo wr_cust i = mapM_ writeCustom customs
 where
  writeCustom (guid, v) = do
    let p_guid = mkGUID guid
    p_bstr <- marshallBSTR v
    var   <- allocBytes (fromIntegral sizeofVARIANT)
    writeVarString (castPtr p_bstr) var -- poorly named, should be writeVarBSTR
    wr_cust p_guid var
 
  attrs   = idAttributes i

  customs = 
    map customise (filterAttributes attrs ["custom"])
    
  customise (Attribute _ [ ParamLit l1, ParamLit l2]) = (s, litToString l2)
     where
       s = case (litToString l1) of
            ls@('{':_) -> ls
	    xs	       -> '{':xs ++ "}"

  customise (Attribute _ [ ParamExpr (Lit (GuidLit [s]))
			 , ParamExpr (Lit l)
			 ]) = (s, litToString l)
  customise a = error ("setCustInfo: oops - can't handle " ++ showCore (ppAttr a))
			 

\end{code}

\begin{code}
computeTypeFlags :: Id -> Word32
computeTypeFlags i = tflags
 where
  attrs = idAttributes i

  tflags =
    foldr (\ (x,val) acc -> ifSet (attrs `hasAttributeWithName` x) (fromEnum32 val) .|. acc) 0
	  [ ("appobject", TYPEFLAG_FAPPOBJECT)
	  , ("creatable", TYPEFLAG_FCANCREATE)
	  , ("licensed",  TYPEFLAG_FLICENSED)
	  , ("predecl",   TYPEFLAG_FPREDECLID) 
	      -- wild&random guess at how this is done at the ODL level
	      -- - exactly what is the function of that attr anyway?
	  , ("hidden",    TYPEFLAG_FHIDDEN)
	  , ("control",   TYPEFLAG_FCONTROL)
	  , ("dual",	  TYPEFLAG_FDUAL)
	  , ("nonextensible", TYPEFLAG_FNONEXTENSIBLE)
	  , ("oleautomation", TYPEFLAG_FOLEAUTOMATION)
	  , ("restricted",    TYPEFLAG_FRESTRICTED)
	  , ("aggregatable",  TYPEFLAG_FAGGREGATABLE)
	  ]

computeVarFlags :: Id -> Word16
computeVarFlags i = wflags
  where
  attrs = idAttributes i

  wflags =
    foldr (\ (x,val) acc -> ifSet (attrs `hasAttributeWithName` x) (fromEnum16 val) .|. acc) 0
	  [ ("readonly", VARFLAG_FREADONLY)
	  , ("source",   VARFLAG_FSOURCE)
	  , ("bindable", VARFLAG_FBINDABLE)
	  , ("requestedit", VARFLAG_FREQUESTEDIT)
	  , ("displaybind", VARFLAG_FDISPLAYBIND)
	  , ("defaultbind", VARFLAG_FDEFAULTBIND)
	  , ("hidden",      VARFLAG_FHIDDEN)
	  , ("restricted",  VARFLAG_FRESTRICTED)
	  , ("defaultcollelem", VARFLAG_FDEFAULTCOLLELEM)
	  , ("uidefault",    VARFLAG_FUIDEFAULT)
	  , ("nonbrowsable", VARFLAG_FNONBROWSABLE)
	  , ("replaceable",   VARFLAG_FREPLACEABLE)
	  , ("immediatebind", VARFLAG_FIMMEDIATEBIND)
	  ]

\end{code}

\begin{code}
  END_SUPPORT_TYPELIBS -}
\end{code}